1 : C ADCHEL SOURCE PV 11/04/08 21:15:00 6936 2 : SUBROUTINE ADCHEL(IPCHE1,IPCHE2,IPCHAD,IEPS) 3 : *_______________________________________________________________________ 4 : * 5 : * ADDITION / SOUSTRACTION DE 2 CHPS PAR ELEMENTS 6 : * 7 : * ( ADDITION :IEPS=1 ; SOUSTRACTION IEPS=-1 ) 8 : * 9 : * ENTREE : 10 : * -------- 11 : * 12 : * IPCHE1 POINTEUR SUR LE PREMIER CHAMPS (TYPE MCHAML) 13 : * IPCHE2 POINTEUR SUR LE DEUXIEME CHAMPS (TYPE MCHALM) 14 : * IEPS = 1 ADDITION 15 : * =-1 SOUSTRACTION 16 : * 17 : * SORTIE : 18 : * ________ 19 : * 20 : * IPCHAD POINTEUR SUR LE CHAMPS SOMME (TYPE MCHAML) 21 : * = 0 SI L OPERATION EST IMPOSSIBLE 22 : * 23 : * MESSAGE D ERREUR DECHENCHE SI IPCHAD=0 24 : * 25 : * LES 2 CHAM PAR ELEMENT PEUVENT AVOIR DES SUPPORTS GEOMETRIQUES 26 : * DIFFERENTS POUR PEU QUE LES OBJETS AFFECTES ELEMENTAIRES QUI LES 27 : * SOUS TENDENT FORMENT UNE PARTITION DE LA GEOMETRIE 28 : * 29 : * CODE EBERSOLT JUILLET 84 PASSAGE 4331 FEVRIER 85 30 : * 31 : * ON PEUT ADDITIONNER A UN CHAMELEM QUELCONQUE UN CHAMELEM A UNE 32 : * COMPOSANTE 33 : * 34 : * MODIFIE SEPTEMBRE 86 35 : * 36 : * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 29 10 90 37 : * +PP EXTENSION ADDITION P.PEGON 24/11/92 38 : *_______________________________________________________________________ 39 : * 40 : IMPLICIT INTEGER(I-N) 41 : IMPLICIT REAL*8(A-H,O-Z) 42 : -INC SMCHAML 43 : -INC SMLREEL 44 : -INC SMCOORD 45 : -INC CCOPTIO 46 : * 47 : SEGMENT MZONG 48 : INTEGER NZONG(0) 49 : ENDSEGMENT 50 : * 51 : SEGMENT MZON1 52 : INTEGER NZON1(0) 53 : ENDSEGMENT 54 : * 55 : SEGMENT MZON2 56 : INTEGER NZON2(0) 57 : ENDSEGMENT 58 : * 59 : SEGMENT ITAFF 60 : INTEGER JTAFF(0) 61 : ENDSEGMENT 62 : * 63 : SEGMENT MPTVAL 64 : INTEGER IPOS(NS) ,NSOF(NS) 65 : INTEGER IVAL(NCOSOU) 66 : CHARACTER*16 TYVAL(NCOSOU) 67 : ENDSEGMENT 68 : * 69 : PARAMETER ( NINF=3 ) 70 : INTEGER INFOS(NINF) 71 : CHARACTER*72 MOT 72 : CHARACTER*16 CONCH1,CONCH2 73 : * 74 : IF(IEPS.EQ. 1) XX= 1 75 : IF(IEPS.EQ.-1) XX=-1 76 : if (ieps.eq.-1) then 77 : * write (6,*) ' adchel soustraction de chamelem ' 78 : endif 79 : 80 : 81 : 82 : IF(IPCHE1.NE.IPCHE2) GOTO 1000 83 : * 84 : * SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL 85 : * 86 : MCHEL1=IPCHE1 87 : MCHEL2=IPCHE2 88 : SEGINI,MCHELM=MCHEL1 89 : IPCHAD = MCHELM 90 : NSOUS = IMACHE(/1) 91 : IF (IEPS.EQ. 1) XX=2 92 : IF (IEPS.EQ.-1) XX=0 93 : * 94 : DO 110 IA=1,NSOUS 95 : MCHAM1=ICHAML(IA) 96 : SEGINI,MCHAML=MCHAM1 97 : ICHAML(IA)=MCHAML 98 : DO 111 ICOMP=1,IELVAL(/1) 99 : MELVA1 = IELVAL(ICOMP) 100 : SEGINI,MELVAL=MELVA1 101 : N1PTEL=VELCHE(/1) 102 : IF (N1PTEL.EQ.0) THEN 103 : N2PTEL=IELCHE(/1) 104 : N2EL =IELCHE(/2) 105 : IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 106 : DO 1 IGAU=1,N2PTEL 107 : DO 1 IB=1,N2EL 108 : MLREE1=IELCHE(IGAU,IB) 109 : IF(MLREE1.EQ.0)THEN 110 : MLREEL=MLREE1 111 : ELSE 112 : SEGACT MLREE1 113 : JG=MLREE1.PROG(/1) 114 : SEGINI MLREEL 115 : DO 2 IPROG=1,JG 116 : PROG(IPROG)=XX*MLREE1.PROG(IPROG) 117 : 2 CONTINUE 118 : SEGDES MLREE1,MLREEL 119 : ENDIF 120 : IELCHE(IGAU,IB)=MLREEL 121 : 1 CONTINUE 122 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN 123 : DO 11 IGAU=1,N2PTEL 124 : DO 11 IB=1,N2EL 125 : MEVOL1=IELCHE(IGAU,IB) 125 : CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS) 126 : IELCHE(IGAU,IB)=MEVOL2 127 : 11 CONTINUE 128 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN 129 : DO 3 IGAU=1,N2PTEL 130 : DO 3 IB=1,N2EL 131 : IP=IELCHE(IGAU,IB) 132 : IF(IP.EQ.0)THEN 133 : NBPTS=IP 134 : ELSE 135 : IREF=(IP-1)*(IDIM+1) 136 : * 137 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 138 : * 139 : SEGACT MCOORD 140 : NBNO=XCOOR(/1)/(IDIM+1) 141 : NBNOI=NBNO 142 : NBPTS=NBNO+1 143 : SEGADJ MCOORD 144 : * 145 : DO 4 IC=1,IDIM 146 : XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX 147 : 4 CONTINUE 148 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 149 : ENDIF 150 : IELCHE(IGAU,IB)=NBPTS 151 : 3 CONTINUE 152 : ELSE 153 : * 154 : * NOM DE COMPOSANTE NON RECONNU 155 : * 156 : MOTERR(1:4)=NOMCHE(ICOMP) 156 : CALL ERREUR(197) 157 : IPCHAD=0 158 : SEGDES MCHEL1,MCHEL2 159 : SEGSUP MELVAL,MCHAML,MCHELM 160 : RETURN 161 : ENDIF 162 : ELSE 163 : N1EL=VELCHE(/2) 164 : DO 5 IGAU=1,N1PTEL 165 : DO 5 IB=1,N1EL 166 : VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB) 167 : 5 CONTINUE 168 : ENDIF 169 : IELVAL(ICOMP) = MELVAL 170 : SEGDES MELVAL,melva1 171 : 111 CONTINUE 172 : SEGDES MCHAML 173 : 110 CONTINUE 174 : SEGDES MCHELM 175 : GOTO 777 176 : * 177 : * CAS GENERAL 178 : * 179 : 1000 CONTINUE 180 : MCHEL1=IPCHE1 181 : MCHEL2=IPCHE2 182 : SEGACT MCHEL1 183 : SEGACT MCHEL2 184 : IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000 185 : * 186 : * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS 187 : * DE SS TYPE DIFFERENTS 188 : * 189 : MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) 189 : CALL ERREUR(99) 190 : IPCHAD=0 191 : GOTO 666 192 : *_______________________________________________________________________ 193 : * 194 : * CAS GENERAL 195 : *_______________________________________________________________________ 196 : * 197 : 3000 CONTINUE 198 : MOT=MCHEL1.TITCHE 199 : L1=MCHEL1.TITCHE(/1) 200 : IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE'.OR.MOT.EQ.'RIGIDITE'. 201 : & OR.MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'. 202 : & OR.MOT.EQ.'SCALAIRE') THEN 203 : MOT=MCHEL2.TITCHE 204 : L1=MCHEL2.TITCHE(/1) 205 : ENDIF 206 : N3=MCHEL1.INFCHE(/2) 207 : NSOUS1=MCHEL1.ICHAML(/1) 208 : NSOUS2=MCHEL2.ICHAML(/1) 209 : * 210 : * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE 211 : * 212 : IF(NSOUS1.NE.NSOUS2) GOTO 4000 213 : * 214 : SEGINI ITAFF 215 : DO 17 ISOUS1=1,NSOUS1 216 : IPMAI1 = MCHEL1.IMACHE(ISOUS1) 217 : CONCH1 = MCHEL1.CONCHE(ISOUS1) 218 : DO 18 ISOUS2=1,NSOUS2 219 : ISOUS=ISOUS2 220 : IPMAI2= MCHEL2.IMACHE(ISOUS) 221 : CONCH2= MCHEL2.CONCHE(ISOUS) 222 : IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN 223 : * 224 : * VERIFICATION POUR LES INFCHE 225 : * 225 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 226 : IF (IRTD.EQ.0) GOTO 18 227 : IMINT1=0 228 : IMINT2=0 229 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 230 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 231 : IF (IMINT1.EQ.IMINT2) GOTO 171 232 : IMINT1=1 233 : IMINT2=1 234 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 235 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 236 : IF (IMINT1.EQ.0) IMINT1=1 237 : IF (IMINT2.EQ.0) IMINT2=1 238 : IF (IMINT1.EQ.IMINT2) GOTO 171 239 : * 240 : * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS 241 : * DE SS TYPE DIFFERENTS 242 : * 243 : MOTERR(1:8)=MCHEL1.TITCHE 244 : MOTERR(9:16)=MCHEL2.TITCHE 244 : CALL ERREUR(329) 245 : SEGDES MCHEL1,MCHEL2 246 : SEGSUP ITAFF 247 : IPCHAD=0 248 : RETURN 249 : ENDIF 250 : 18 CONTINUE 251 : SEGSUP ITAFF 252 : GOTO 4000 253 : * 254 : 171 CONTINUE 255 : JTAFF(**)=MCHEL2.ICHAML(ISOUS) 256 : 17 CONTINUE 257 : * 258 : * ON A TROUVE UNE BIJECTION ET ON VECTORISE 259 : * 260 : N1=NSOUS1 261 : SEGINI MCHELM 262 : TITCHE=MOT 263 : IFOCHE=IFOUR 264 : IPCHAD=MCHELM 265 : DO 400 ISOUS=1,NSOUS1 266 : IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) 267 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 268 : DO 401 N33=1,N3 269 : INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 270 : 401 CONTINUE 271 : * 272 : MCHAM1=MCHEL1.ICHAML(ISOUS) 273 : * 274 : SEGINI,MCHAML=MCHAM1 275 : ICHAML(ISOUS)=MCHAML 276 : IPCHA=MCHAML 277 : * 278 : MCHAM2=JTAFF(ISOUS) 279 : SEGACT MCHAM2 280 : IPCHA2=MCHAM2 281 : * 281 : CALL ADCHAM (IPCHA2,IPCHA,XX) 282 : IF (IPCHA.EQ.0) THEN 283 : SEGSUP ITAFF 284 : GOTO 9990 285 : ENDIF 286 : * 287 : *pv SEGDES MCHAML,MCHAM2,MCHAM1 288 : SEGDES MCHAML 289 : 400 CONTINUE 290 : *pv SEGDES MCHEL1,MCHEL2 291 : SEGSUP ITAFF 292 : SEGDES MCHELM 293 : GOTO 666 294 : *_______________________________________________________________________ 295 : * 296 : * ON A PAS TROUVE DE BIJECTION 297 : *_______________________________________________________________________ 298 : * 299 : 4000 CONTINUE 300 : SEGINI MZONG,MZON1,MZON2 301 : DO 500 ISOUS1=1,NSOUS1 302 : NZONG(**)=MCHEL1.IMACHE(ISOUS1) 303 : NZON1(**)=ISOUS1 304 : NZON2(**)=0 305 : 500 CONTINUE 306 : IWRN=0 307 : DO 510 ISOUS2=1,NSOUS2 308 : IPMAI2 = MCHEL2.IMACHE(ISOUS2) 309 : CONCH2 = MCHEL2.CONCHE(ISOUS2) 310 : DO 520 ISOUS1=1,NSOUS1 311 : IPMAI1= MCHEL1.IMACHE(ISOUS1) 312 : CONCH1= MCHEL1.CONCHE(ISOUS1) 313 : IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN 313 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 314 : IF (IRTD.EQ.0) GOTO 520 315 : * 316 : * VERIFICATION POUR LES MINTES 317 : * 318 : IF ( MCHEL1.INFCHE(ISOUS1,6).EQ. 319 : & MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530 320 : * 321 : * ERREUR SUR LES SUPPORTS DES MCHAML 322 : * 323 : MOTERR(1:8)=MCHEL1.TITCHE 324 : MOTERR(9:16)=MCHEL2.TITCHE 324 : CALL ERREUR(329) 325 : IPCHAD=0 326 : SEGDES MCHEL1,MCHEL2 327 : SEGSUP MZONG,MZON1,MZON2 328 : RETURN 329 : * 330 : ENDIF 331 : 520 CONTINUE 332 : IWRN=1 333 : NZONG(**)=IPMAI2 334 : NZON1(**)=0 335 : NZON2(**)=ISOUS2 336 : GOTO 510 337 : * 338 : 530 CONTINUE 338 : if (nzon2(isous1).ne.0) call erreur(329) 339 : NZON2(ISOUS1)=ISOUS2 340 : 510 CONTINUE 341 : * 342 : * WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2 343 : * 343 : * IF(IWRN.EQ.1) CALL ERREUR(103) 344 : NSOUS=NZONG(/1) 345 : N1=NSOUS 346 : SEGINI MCHELM 347 : TITCHE=MOT 348 : IFOCHE=IFOUR 349 : IPCHAD=MCHELM 350 : * 351 : DO 540 ISOUS=1,NSOUS 352 : IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550 353 : * 354 : IF(NZON1(ISOUS).NE.0) THEN 355 : MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) ) 356 : SEGINI,MCHAML=MCHAM1 357 : IMACHE(ISOUS)=NZONG(ISOUS) 358 : CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) ) 359 : DO 402 N33=1,N3 360 : INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33) 361 : 402 CONTINUE 362 : * 363 : ENDIF 364 : IF(NZON2(ISOUS).NE.0) THEN 365 : MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) ) 366 : SEGINI,MCHAML=MCHAM2 367 : IMACHE(ISOUS)=NZONG(ISOUS) 368 : CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) ) 369 : DO 403 N33=1,N3 370 : INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33) 371 : 403 CONTINUE 372 : * 373 : ENDIF 374 : ICHAML(ISOUS)=MCHAML 375 : * 376 : DO 175 ICOMP=1,IELVAL(/1) 377 : MELVA1=IELVAL(ICOMP) 378 : SEGINI,MELVAL=MELVA1 379 : IELVAL(ICOMP)=MELVAL 380 : *pv SEGDES MELVAL,melva1 381 : SEGDES melval 382 : 175 CONTINUE 383 : SEGDES MCHAML 384 : * 385 : GOTO 540 386 : * 387 : 550 CONTINUE 388 : MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) ) 389 : SEGINI,MCHAML=MCHAM1 390 : IMACHE(ISOUS)=NZONG(ISOUS) 391 : CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) ) 392 : DO 404 N33=1,N3 393 : INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33) 394 : 404 CONTINUE 395 : ICHAML(ISOUS)=MCHAML 396 : IPCHA=MCHAML 397 : MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) ) 398 : SEGACT MCHAM2 399 : IPCHA2=MCHAM2 400 : * 400 : CALL ADCHAM (IPCHA2,IPCHA,XX) 401 : IF (IPCHA.EQ.0) THEN 402 : SEGSUP MZONG,MZON1,MZON2 403 : GOTO 9990 404 : ENDIF 405 : * 406 : *pv SEGDES MCHAML,MCHAM2 407 : SEGDES MCHAML 408 : 540 CONTINUE 409 : SEGDES MCHELM 410 : * 411 : SEGSUP MZONG,MZON1,MZON2 412 : GOTO 666 413 : * 414 : 9990 CONTINUE 415 : * 416 : * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR 417 : * 418 : SEGDES MCHEL1,MCHEL2,MCHAM2 419 : SEGSUP MCHAML,MCHELM,ITAFF 420 : IPCHAD=0 421 : RETURN 422 : * 423 : 666 CONTINUE 424 : *pv SEGDES MCHEL1,MCHEL2 425 : 777 CONTINUE 426 : RETURN 427 : END 428 : 429 : 430 : 431 : 432 : 433 : 434 : 435 : 436 : 437 : 438 : 439 :
© Cast3M 2003 - All rights reserved.
Disclaimer