1 : C DEPIMP SOURCE CHAT 09/10/09 21:17:07 6519 2 : SUBROUTINE DEPIMP 3 : 4 : IMPLICIT INTEGER(I-N) 5 : CHARACTER*4 charm,charre 6 : REAL*8 XXA,vval,X0,X1 7 : LOGICAL ISCALA 8 : C 9 : C **** CE SUBROUTINE SERT A IMPOSER DES VALEURS DE DEPLACEMENTS 10 : C **** IMPOSES NON NULS. 11 : C 12 : C SYNTAXE TOTO = DEPIMPOSE BRIG FLOT 13 : C 14 : C OU TOTO = DEPIMPOSE BRIG CHPSCAL 15 : C TOTO = DEPIMPOSE BRIG CHPOI ( COMPOSANTES PRIMALES) 16 : C 17 : C EN ENTREE : BRIG OBJET RIGIDITE DE TYPE BLOQUAGE 18 : C FLOT LA VALEUR DU DEPLACEMENT A IMPOSER 19 : C CHPSCAL EST UN CHPOINT DE SCALAIRE QUI PRECISE LA 20 : C VALEUR A IMPOSER EN CHAQUE POINT. 21 : C 22 : C EN SORTIE UN OBJET DE TYPE CHPOINT 23 : C 24 : -INC SMRIGID 25 : -INC SMCHPOI 26 : -INC CCOPTIO 27 : -INC SMELEME 28 : -INC SMCOORD 29 : -INC SMTABLE 30 : 31 : SEGMENT SCOLOR 32 : CHARACTER*4 COLOR(NBELEM) 33 : ENDSEGMENT 34 : POINTEUR SCOL1.SCOLOR,SCOL2.SCOLOR,SCOL3.SCOLOR 35 : SEGMENT ICPR(NNN) 36 : segment irelat 37 : logical lrelat(nnn) 38 : end segment 39 : logical lllblo,lllrel 40 : 41 : c lecture table liaisons statiques 41 : CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou) 42 : if (iretou.ne.0) goto 1100 43 : C 44 : C **** LECTURE D'UN OBJET DE TYPE RIGIDITE 45 : C 45 : CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU) 46 : IF(IERR.NE.0) RETURN 47 : C 48 : C LECTURE D'UNE VALEUR SI ECHEC LECTURE D'UN CHPOINT DE SCALAIRES 49 : C OU DE COMPOSANTES PRIMALES DES BLOQUAGES 50 : C 50 : CALL LIRREE(XXA,0,IREVAL) 51 : VVAL=XXA 52 : IF(IREVAL.EQ.0) THEN 52 : CALL LIROBJ('CHPOINT ',ISCA,1,IRETOU) 53 : IF(IERR.NE.0) RETURN 54 : MCHPO1=ISCA 55 : SEGACT MCHPO1 56 : nbszch = MCHPO1.ipchp(/1) 57 : if(nbszch.lt.1) then 58 : segdes,MCHPO1 59 : moterr(1:8)='CHPOINT ' 60 : interr(1)=isca 60 : call erreur(356) 61 : endif 62 : msoup1 = MCHPO1.ipchp(1) 63 : segact msoup1 64 : nbcomp = msoup1.noharm(/1) 65 : c ... ISCALA = .TRUE. correspond au traitement d'un CHPOINT 66 : c contenant une seule zone dans laquelle il y a une seule 67 : c composante et dont le nom peut être quelconque. Pour 68 : c l'instant on s'en sert pour vérifier si le CHPOINT est bel 69 : c et bien SCALAIRE ... 70 : if(nbszch.eq.1.AND.nbcomp.eq.1) then 71 : iscala = .TRUE. 72 : else 73 : ISCALA = .FALSE. 74 : endif 75 : ENDIF 76 : c 77 : c ... test si la RIGIDITE n'est pas vide, si OUI on créé un CHPOINT 78 : c vide puis on s'en va ... 79 : c 80 : MRIGID=IPOIRI 81 : SEGACT,MRIGID 82 : NNN=IRIGEL(/2) 83 : IF (NNN.EQ.0) THEN 84 : NSOUPO=0 85 : NAT=1 86 : SEGINI MCHPOI 87 : MTYPOI='FLX' 88 : JATTRI(1) = 2 89 : MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'// 90 : # ' DEPIMP' 91 : IFOPOI = IFOUR 92 : SEGDES MCHPOI 93 : GO TO 252 94 : ENDIF 95 : 96 : IPT2=0 97 : NOHA=0 98 : C 99 : C BOUCLE SUR LES SOUS RIGIDITES . ON VERIFIE QUE LAMBDA EXISTE ET ON 100 : C CONSTRUIT LE SEGMENT GEOMETRIE LX1 LX2 NNOE, DANS scol1.COLOR ON MET LE 101 : C NOM DE L'INCONNUE 102 : C 103 : segini,irelat 104 : DO 1 NN=1,NNN 105 : DESCR=IRIGEL(3,NN) 106 : MELEME=IRIGEL(1,NN) 107 : NOHAR=IRIGEL(5,NN) 108 : IF(NOHA.NE.0.AND.NOHA.NE.NOHAR) THEN 108 : CALL ERREUR ( 25 ) 109 : RETURN 110 : ENDIF 111 : lrelat(nn) = .false. 112 : c ... on va chercher les multiplicateurs dans DESCR ... 113 : SEGACT,DESCR 114 : IA=LISINC(/2) 115 : DO 2 I=1,IA 116 : IF(LISINC(I).EQ.'LX ') GO TO 3 117 : 2 CONTINUE 118 : c ... on n'a pas trouvé de multiplicateurs, donc bye ... 119 : SEGDES,DESCR 119 : CALL ERREUR(245) 120 : RETURN 121 : c ... on a trouvé les multiplicateurs ... 122 : 3 CONTINUE 123 : SEGACT,MELEME 124 : NBNN=2 125 : NBELEM=NUM(/2) 126 : NBREF=0 127 : NBSOUS=0 128 : SEGINI,IPT1,SCOL1 129 : c ... boucle sur les éléments de blocage ... 130 : DO 4 J=1,NUM(/2) 131 : JB=0 132 : c ... JA sert à compter les multiplicateurs dans chaque 133 : c élément, normalement il y en a 2 ... 134 : JA=0 135 : c ... boucle sur les noeuds de ces éléments ... 136 : DO 4 K=1,NUM(/1) 137 : c ... si c'est un support de multiplicateur, on met son n° 138 : c dans IPT1 (position 1 ) ... 139 : IF(LISINC(K).EQ.'LX ') THEN 140 : JA=JA+1 141 : IPT1.NUM(JA,J)=NUM(NOELEP(K),J) 142 : c ... sinon ... 143 : ELSE 144 : c ... on teste si c'est le premier DDL <>, si OUI ... 145 : IF(JB.EQ.0) THEN 146 : c ... on met son n° dans IPT1 (position 2) ... 147 : JB=2 148 : IPT1.NUM(JB,J)=NUM(NOELEP(K),J) 149 : C ... et le nom du DDL dans SCOL1.COLOR ... 150 : SCOL1.COLOR(J)=LISINC(K) 151 : c ... sinon (c.à d. ceci est une relation et non un blocage) ... 152 : ELSE 153 : c ... on teste si le support n'est pas le même que 154 : c celui du premier DDL < > ... 155 : IF(IPT1.NUM(JB,J).NE.NUM(NOELEP(K),J)) THEN 156 : c ... si c'est le cas on sert une ERREUR en cas de lecture d'un CHPOINT ... 157 : IF(IREVAL.ne.1) then 157 : CALL ERREUR(794) 158 : RETURN 159 : endif 160 : ENDIF 161 : c ... et de toute façon on efface le nom du DDL de SCOL1.COLOR ... 162 : SCOL1.COLOR(J)=' ' 163 : lrelat(nn) = .true. 164 : ENDIF 165 : ENDIF 166 : 4 CONTINUE 167 : 168 : C 169 : C SI NN= 1 IPT2 = IPT1; SINON IPT3 = IPT2 + IPT1, PUIS IPT2 = IPT3 170 : C 171 : SEGDES,DESCR 172 : IF(IPT2.NE.0) GO TO 5 173 : IPT2=IPT1 174 : SCOL2=SCOL1 175 : SEGDES,MELEME 176 : GO TO 1 177 : 5 CONTINUE 178 : NA=IPT1.NUM(/2) 179 : NB=IPT2.NUM(/2) 180 : NBELEM=NA+NB 181 : SEGINI,IPT3,SCOL3 182 : DO 71 I=1,NA 183 : SCOL3.COLOR(I)=SCOL1.COLOR(I) 184 : DO 72 J=1,2 185 : IPT3.NUM(J,I)=IPT1.NUM(J,I) 186 : 72 CONTINUE 187 : 71 CONTINUE 188 : DO 8 I=1,NB 189 : SCOL3.COLOR(I+NA)=SCOL2.COLOR(I) 190 : DO 9 J=1,2 191 : IPT3.NUM(J,I+NA)=IPT2.NUM(J,I) 192 : 9 CONTINUE 193 : 8 CONTINUE 194 : SEGSUP IPT1,SCOL1 195 : SEGSUP,IPT2,SCOL2 196 : IPT2=IPT3 197 : SCOL2=SCOL3 198 : SEGDES,MELEME 199 : 1 CONTINUE 200 : SEGDES,MRIGID 201 : c 202 : c ... on va vérifier si la matrice contient seulement les blocages, ou seulement 203 : c les relations (on en a seulement besoin en cas de lecture d'un CHPOINT) ... 204 : c 205 : if(ireval.eq.0) then 206 : lllblo = .true. 207 : lllrel = .true. 208 : do 77 i=1,nnn 209 : lllblo = lllblo .and. (.not.lrelat(i)) 210 : lllrel = lllrel .and. lrelat(i) 211 : 77 continue 212 : segsup,irelat 213 : c ... si les deux sont faux, on a un mélange de blocages et de relations ... 214 : if(.not.lllblo .and. .not.lllrel) then 214 : call erreur(795) 215 : return 216 : endif 217 : c ... si on n'a que des relations, le CHPOINT doit être scalaire ... 218 : if(lllrel .and. .not.iscala) then 218 : call erreur(796) 219 : return 220 : endif 221 : else 222 : segsup,irelat 223 : endif 224 : C 225 : C ON VIENT DE CREER IPT2 CONTENANT DES ELEMENTS COMPOSES DE LX1 NOE 226 : C DANS COLOR ON A LE NOM DE L'INCONNUE A METTRE EN FACE DE NNOE 227 : C 228 : NSOUPO=1 229 : NAT=1 230 : SEGINI,MCHPOI 231 : MTYPOI='FLX' 232 : JATTRI(1) = 2 233 : MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'// 234 : # ' DEPIMP' 235 : IFOPOI=IFOUR 236 : 237 : NC=1 238 : SEGINI,MSOUPO 239 : IPCHP(1)=MSOUPO 240 : SEGDES,MCHPOI 241 : NOCOMP(1)='FLX' 242 : NOHARM(1)=NOHAR 243 : write (charm,fmt='(A4)') nohar 244 : if (charm.eq.'NOHA') noharm(1)=nifour 245 : C 246 : C CREATION DE L'ELEMENT SUPPORT GEOMETRIQUE ET EN MEME TEMPS DES 247 : C VALEURS VPOCHA 248 : C 249 : NBNN=1 250 : NBELEM=IPT2.NUM(/2) 251 : SEGINI MELEME 252 : IGEOC=MELEME 253 : ITYPEL=1 254 : 255 : N=IPT2.NUM(/2) 256 : SEGINI,MPOVAL 257 : IPOVAL=MPOVAL 258 : SEGDES,MSOUPO 259 : 260 : c ... Si on a lu un réél, il n'y a pas grand chose à faire ... 261 : IF(IREVAL.NE.0) GO TO 250 262 : C 263 : C CAS DU CHPOINT SCALAIRE, on peut mettre un teste qui porte seulement 264 : C sur ISCALA car on a déjà vérifié que cela va ensemble avec LLLREL 265 : C 266 : IF(ISCALA) THEN 267 : MSOUP1=MCHPO1.IPCHP(1) 268 : SEGACT MSOUP1 269 : MPOVA1=MSOUP1.IPOVAL 270 : SEGACT MPOVA1 271 : NNN=XCOOR(/1)/(IDIM+1) 272 : SEGINI ICPR 273 : IPT3=MSOUP1.IGEOC 274 : SEGACT IPT3 275 : NNU=IPT3.NUM(/2) 276 : DO 25 IUY=1,NNU 277 : ICPR(IPT3.NUM(1,IUY))=IUY 278 : 25 CONTINUE 279 : DO 26 IU=1,IPT2.NUM(/2) 280 : JA=IU 281 : NUM(1,JA)=IPT2.NUM(1,IU) 282 : ID=ICPR(IPT2.NUM(2,IU)) 283 : IF( ID.EQ.0) THEN 283 : CALL ERREUR(244) 284 : RETURN 285 : ELSE 286 : XXA=MPOVA1.VPOCHA(ID,1) 287 : VPOCHA(JA,1)=XXA 288 : ENDIF 289 : 26 CONTINUE 290 : SEGDES MPOVA1,MSOUP1,MCHPO1 291 : SEGDES IPT3 292 : SEGSUP ICPR 293 : ELSE 294 : C 295 : C CAS DU CHPOINT D'INCONNUES PRIMALES 296 : C 297 : NNN=XCOOR(/1)/(IDIM+1) 298 : SEGINI ICPR 299 : JB=1 300 : DO 36 J=1,IPT2.NUM(/2) 301 : NUM(1,JB)=IPT2.NUM(1,J) 302 : JB=JB+1 303 : 36 CONTINUE 304 : DO 31 I=1,MCHPO1.IPCHP(/1) 305 : DO 40 J=1,NNN 306 : ICPR(J)=0 307 : 40 CONTINUE 308 : MSOUP1=MCHPO1.IPCHP(I) 309 : SEGACT MSOUP1 310 : MPOVA1=MSOUP1.IPOVAL 311 : SEGACT MPOVA1 312 : IPT1=MSOUP1.IGEOC 313 : SEGACT IPT1 314 : IA=0 315 : DO 32 J=1,IPT1.NUM(/2) 316 : ID=IPT1.NUM(1,J) 317 : IF(ICPR(ID).EQ.0) THEN 318 : IA=IA+1 319 : ICPR(ID)=IA 320 : ELSE 320 : CALL ERREUR(245) 321 : RETURN 322 : ENDIF 323 : 32 CONTINUE 324 : DO 33 J=1,IPT2.NUM(/2) 325 : ID=IPT2.NUM(2,J) 326 : JB=JB+2 327 : IF(ICPR(ID).EQ.0) GO TO 33 328 : DO 34 K=1,MSOUP1.NOCOMP(/2) 329 : IF(MSOUP1.NOCOMP(K).EQ.SCOL2.COLOR(J)) GO TO 35 330 : 34 CONTINUE 331 : GO TO 33 332 : 35 CONTINUE 333 : JD=ICPR(ID) 334 : XXA=MPOVA1.VPOCHA(JD,K) 335 : JA=J 336 : VPOCHA(JA,1)=XXA 337 : 33 CONTINUE 338 : SEGDES MSOUP1,MPOVA1,IPT1 339 : 31 CONTINUE 340 : SEGSUP ICPR 341 : ENDIF 342 : GO TO 251 343 : 344 : C ... En cas de lecture d'un réél le remplissage du segment MPOVAL est assez simple ... 345 : 250 CONTINUE 346 : DO 10 I=1,N 347 : VPOCHA(I,1)=VVAL 348 : 10 CONTINUE 349 : c ... celui du segment MELEME n'est pas plus compliqué ... 350 : DO 11 I=1,IPT2.NUM(/2) 351 : JA=I 352 : NUM(1,JA)=IPT2.NUM(1,I) 353 : 11 CONTINUE 354 : 355 : 251 CONTINUE 356 : SEGSUP IPT2,SCOL2 357 : SEGDES,MPOVAL,MELEME 358 : 252 CONTINUE 358 : CALL ECROBJ('CHPOINT ',MCHPOI) 359 : RETURN 360 : 361 : 1100 CONTINUE 361 : call depim2(ipt) 362 : return 363 : 364 : END 365 : 366 : 367 : 368 : 369 : 370 : 371 : 372 : 373 : 374 : 375 : 376 : 377 :
© Cast3M 2003 - All rights reserved.
Disclaimer