1 : C TOCH1 SOURCE PV 09/03/12 21:35:57 6325 2 : C TOCH1 3 : C CE SOUS PROGRAMME EST APPELE PAR PROPER. 4 : C IL GERE LA ROTATION DES COMPOSANTES DES CHPOINT, MCHAML 5 : C SOURCE MO + CHARRAS 97/07/29 6 : C MODIF KICH 97/11 7 : C les differentes etapes sont commentees le long du programme. 8 : 9 : SUBROUTINE TOCH1 (IP1,MOTYPE,IRETO) 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8 (A-H,O-Z) 12 : REAL*8 SIGM(3,3),QRtQ(3,3),NSIG(3,3),RtQ(3,3) 13 : CHARACTER*4 MOIC, MOTYPE*8 14 : CHARACTER*14 MESSER, TYPIC*16 15 : LOGICAL LAG 16 : COMMON /CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, 17 : # ZVEC,ANGLE,ICLE 18 : -INC CCOPTIO 19 : -INC SMCOORD 20 : -INC SMELEME 21 : -INC SMCHPOI 22 : -INC SMCHAML 23 : -INC TMTRAV 24 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 25 : SEGMENT MSWBLO 26 : CHARACTER*4 MOTDDL(0) 27 : ENDSEGMENT 28 : 29 : SEGMENT MSWBL1 30 : CHARACTER*4 MOZO(IZO,NOCO) 31 : INTEGER NOCCH1(IZO,NOCO) 32 : INTEGER TRIGO1(IZO,NOCO) 33 : ENDSEGMENT 34 : * 35 : CHARACTER*4 AAA(4,6) 36 : * 37 : CHARACTER*4 MODEPL(5) 38 : CHARACTER*4 MODEDU(5) 39 : CHARACTER*4 MORODU(5) 40 : CHARACTER*4 MOROTA(5) 41 : CHARACTER*4 MOCONT(6) 42 : CHARACTER*4 MODEFO(6) 43 : C AAA(1,..) 44 : DATA MODEPL(1)/'UX '/ 45 : DATA MODEPL(2)/'UY '/ 46 : DATA MODEPL(3)/'UZ '/ 47 : DATA MODEPL(4)/'UR '/ 48 : DATA MODEPL(5)/'UZ '/ 49 : C DATA MODEPL(6)/'UT '/ 50 : C AAA(2,..) 51 : DATA MODEDU(1)/'FX '/ 52 : DATA MODEDU(2)/'FY '/ 53 : DATA MODEDU(3)/'FZ '/ 54 : DATA MODEDU(4)/'FR '/ 55 : DATA MODEDU(5)/'FZ '/ 56 : C AAA(3,..) 57 : DATA MOROTA(1)/'RX '/ 58 : DATA MOROTA(2)/'RY '/ 59 : DATA MOROTA(3)/'RZ '/ 60 : DATA MOROTA(4)/' '/ 61 : DATA MOROTA(5)/' '/ 62 : C AAA(4,..) 63 : DATA MORODU(1)/'MX '/ 64 : DATA MORODU(2)/'MY '/ 65 : DATA MORODU(3)/'MZ '/ 66 : DATA MORODU(4)/' '/ 67 : DATA MORODU(5)/' '/ 68 : 69 : DATA MOCONT(1)/'SMXX'/ 70 : DATA MOCONT(2)/'SMYY'/ 71 : DATA MOCONT(3)/'SMZZ'/ 72 : DATA MOCONT(4)/'SMXY'/ 73 : DATA MOCONT(5)/'SMXZ'/ 74 : DATA MOCONT(6)/'SMYZ'/ 75 : C 76 : DATA MODEFO(1)/'EPXX'/ 77 : DATA MODEFO(2)/'EPYY'/ 78 : DATA MODEFO(3)/'EPZZ'/ 79 : DATA MODEFO(4)/'GAXY'/ 80 : DATA MODEFO(5)/'GAXZ'/ 81 : DATA MODEFO(6)/'GAYZ'/ 82 : C 83 : IF (MOTYPE.EQ.'CHPOINT ') GOTO 100 84 : IF (MOTYPE.EQ.'MCHAML ') GOTO 200 85 : 86 : 100 CONTINUE 87 : MCHPO1 = IP1 88 : 89 : C creation matrice aaa 4 col 5 lignes 90 : DO I=1,5 91 : AAA(1,I)=MODEPL(I) 92 : AAA(2,I)=MODEDU(I) 93 : AAA(3,I)=MOROTA(I) 94 : AAA(4,I)=MORODU(I) 95 : ENDDO 96 : 97 : NBMDDL=0 98 : LDDLA=0 99 : SEGACT MCHPO1 100 : IZO=MCHPO1.IPCHP(/1) 101 : NOCO=0 102 : SEGINI MSWBLO,MSWBL1 103 : DO 8 I=1,MCHPO1.IPCHP(/1) 104 : NOC=0 105 : MSOUP1=MCHPO1.IPCHP(I) 106 : SEGACT MSOUP1 107 : DO 7 IA=1,MSOUP1.NOCOMP(/2) 108 : MOIC=MSOUP1.NOCOMP(IA) 109 : C B-1):lecture de chpo1 et test si correspondance entre 110 : C la composante moic du chpo1 et une du tableau aaa 111 : C si oui LAG vrai 112 : LAG=.FALSE. 113 : DO 3 ICO=1,4 114 : DO 3 ILIGN=1,6 115 : LAG=(MOIC.EQ.AAA(ICO,ILIGN)) 116 : IF (LAG) THEN 117 : ICOL=ICO 118 : GO TO 4 119 : ENDIF 120 : 3 CONTINUE 121 : 4 CONTINUE 122 : 123 : IF (LAG) THEN 124 : IF(NOC.GE.1) THEN 125 : C la composante est elle deja existante dans cette zone? 126 : DO IAK= 1 ,NOCO 127 : IF(MOIC.EQ.MOZO(I,IAK)) GO TO 7 128 : ENDDO 129 : ENDIF 130 : 131 : C en sortie de boucle ico represente le type de ddl: 132 : C icol =1 --> DEPL, ico =2 --> FORCES 133 : C icol =3 --> ROTA, ico =4 --> MOMENT 134 : 135 : C B-2) determination du nombre et de l appellation des ddl 136 : C a creer pour le chpo tourne selon type de calcul 137 : C initialisations de depart 138 : LDDLA=0 139 : IPOSIA=0 140 : IF(IFOUR.NE.-2.AND.IFOUR.NE.-1.AND.IFOUR.NE.-3) GOTO 101 141 : 142 : C DEFORMATIONS PLANES OU CONTRAINTES PLANES OU DEF PLANE GENE 143 : C DEFO PLAN -1: UX UY 144 : C OU CONT PLAN -2: UX UY 145 : C OU DEF PLANE GENE -3:UX UY UZ 146 : LDDLA=2 147 : IPOSIA=0 148 : GOTO 107 149 : 101 CONTINUE 150 : IF(IFOUR.NE.0) GOTO 102 151 : C 152 : C AXISYMETRIQUE (IFOUR= 0) 153 : C UR UZ 154 : LDDLA=2 155 : IPOSIA=3 156 : GOTO 107 157 : 102 CONTINUE 158 : IF(IFOUR.NE.1) GOTO 103 159 : C 160 : C FOURIER (IFOUR= 1 ) 161 : C UR UZ 162 : LDDLA=2 163 : IPOSIA=3 164 : GOTO 107 165 : 103 CONTINUE 166 : IF(IFOUR.NE.2) GOTO 104 167 : C 168 : C TRIDIM (IFOUR= 2 ) 169 : C UX UY UZ 170 : C FX FY FZ 171 : C RX RY RZ 172 : C MX MY MZ 173 : LDDLA=3 174 : IPOSIA=0 175 : GOTO 107 176 : 104 CONTINUE 177 : C 178 : C DEFORMATIONS GENERALISEES 179 : LDDLA=0 180 : LDDLB=0 181 : IPOSIA=0 182 : IPOSIB=0 183 : 107 CONTINUE 184 : C 185 : IF ((NOC+LDDLA).GT.NOCO) THEN 186 : NOCO=NOC+LDDLA 187 : SEGADJ MSWBL1 188 : ENDIF 189 : 190 : C la composante envoyee est elle compatible avec le mode de calcul?? 191 : DO IAA=1,LDDLA 192 : IF(MOIC.EQ.AAA(ICOL,IPOSIA+IAA)) THEN 193 : GO TO 108 194 : ELSE 195 : IF(IAA.EQ.LDDLA)THEN 196 : IF(IFOUR.EQ.-1)MESSER='DEFO PLAN ' 197 : IF(IFOUR.EQ.-2)MESSER='CONT PLAN ' 198 : IF(IFOUR.EQ.-3)MESSER='DEF PLANE GENE' 199 : IF(IFOUR.EQ.0)MESSER='AXISYMETRIQUE ' 200 : IF(IFOUR.EQ.1)MESSER='FOURIER ' 201 : IF(IFOUR.EQ.2)MESSER='TRIDIM ' 202 : INTERR(1)=I 203 : MOTERR(1:4)=MOIC 204 : MOTERR(5:19)=MESSER 204 : CALL ERREUR (805) 205 : GO TO 999 206 : ELSE 207 : CONTINUE 208 : ENDIF 209 : ENDIF 210 : ENDDO 211 : 108 CONTINUE 212 : 213 : C on remplit motddl 214 : DO IAA=1,LDDLA 215 : MOTDDL(**)=AAA(ICOL,IPOSIA+IAA) 216 : ENDDO 217 : 218 : C remplissage des tableaux,MOZO,TRIGO1 et NOCCH1 219 : C qui serviront a dimensionner le nouveau chpo 220 : 221 : C MOZO contient pour chaque zone le nom des composantes 222 : C et peut aussi....contenir du ' 'ce qui servira. 223 : 224 : C NOCCH1 contient,pour chaque zone, le no d emplacement de 225 : C chaque composante dans le chpo d origine. si une composante 226 : C cree n existait pas dans le chpo de depart alors: 227 : C NOCCH1 (zone,no compos)=0 228 : 229 : C TRIGO1 contient,pour chaque zone,et pour chaque composante 230 : C un nombre qui peut prendre les valeurs: 231 : C -1 si la composante ne doit pas tourner 232 : C 0 si MOZO (I,nomcompos) =' ' 233 : C 3 2 ou 1 si elle doit tourner.la 1ere des ddl d une meme 234 : C famille est indicee a 2 (3 si 3d). 235 : 236 : IF ((NOC + LDDLA).GT.NOCO) THEN 237 : NOCO=NOC+LDDLA 238 : SEGADJ MSWBL1 239 : ENDIF 240 : DO 6 IAA=NBMDDL+1,NBMDDL+LDDLA 241 : NOC= NOC+1 242 : MOZO (I,NOC)=MOTDDL(IAA) 243 : 244 : TRIGO1(I,NOC)=NBMDDL+LDDLA+1-IAA 245 : 246 : DO 5 IAB=IA,MSOUP1.NOCOMP(/2) 247 : IF(MOTDDL(IAA).EQ.MSOUP1.NOCOMP(IAB))THEN 248 : NOCCH1 (I,NOC)=IAB 249 : ELSE 250 : IF(.NOT.LAG)NOCCH1 (I,NOC)=0 251 : ENDIF 252 : 5 CONTINUE 253 : 6 CONTINUE 254 : NBMDDL=NBMDDL+LDDLA 255 : 256 : ELSE 257 : NOC= NOC+1 258 : IF (NOC.GT.NOCO) THEN 259 : NOCO= NOCO+ 1 260 : SEGADJ MSWBL1 261 : ENDIF 262 : MOZO(I,NOC)=MOIC 263 : NOCCH1(I,NOC)=IA 264 : TRIGO1(I,NOC)=-1 265 : 266 : ENDIF 267 : 7 CONTINUE 268 : SEGDES MSOUP1 269 : 8 CONTINUE 270 : SEGDES MSWBLO 271 : 272 : C print*,'en sortie: ' 273 : C print*,'NOCO= ',NOCO 274 : C do iiw=1,NOCCH1 (/1) 275 : C do ijl=1,NOCCH1 (/2) 276 : C print*,'MOZO (',Iiw,',',ijl,')= ',MOZO(Iiw,ijl) 277 : C #,'NOCCH1 (',Iiw,',',ijl,')= ',NOCCH1(Iiw,ijl) 278 : C #,'TRIGO1 (',Iiw,',',ijl,')= ',TRIGO1(Iiw,ijl) 279 : C enddo 280 : C enddo 281 : 282 : C mise a jour des valeurs de toutes les composantes du 283 : C nouveau chpo1 sans tenir compte des rotations 284 : SEGACT, MCHPO1*MOD 285 : MCHPO1.IFOPOI = IFOUR 286 : DO 14 I=1,MCHPO1.IPCHP(/1) 287 : MSOUP1=MCHPO1.IPCHP(I) 288 : DO NC=1,NOCCH1(/2) 289 : IF(MOZO(I,NC).EQ.' ')GO TO 11 290 : ENDDO 291 : 11 CONTINUE 292 : NC=NC-1 293 : SEGINI MSOUP3 294 : MCHPO1.IPCHP(I)=MSOUP3 295 : SEGACT MSOUP1 296 : MSOUP3.IGEOC= MSOUP1.IGEOC 297 : MPOVA1=MSOUP1.IPOVAL 298 : SEGACT MPOVA1 299 : N=MPOVA1.VPOCHA(/1) 300 : SEGINI MPOVA3 301 : MSOUP3.IPOVAL=MPOVA3 302 : DO 13 IC=1,NC 303 : MSOUP3.NOCOMP(IC)=MOZO(I,IC) 304 : ICN= NOCCH1(I,IC) 305 : IF(ICN.EQ.0) GO TO 13 306 : C si composante n existe pas dans le chpo initial 307 : C (car elle est cree pour chpo3) elle reste a 0 308 : DO IB=1,N 309 : MPOVA3.VPOCHA(IB,IC)=MPOVA1.VPOCHA(IB,ICN) 310 : ENDDO 311 : 13 CONTINUE 312 : SEGDES MPOVA3,MSOUP3 313 : SEGSUP MPOVA1,MSOUP1 314 : 14 CONTINUE 315 : SEGDES MCHPO1 316 : C fin mise a jour des valeurs sans rotations 317 : 318 : C mise a jour des valeurs des composantes du 319 : C nouveau chpo1 necessitant la rotation 320 : C TRIGO1(I,IC)= 1 , 2 , 3 au max; 321 : C TRIGO1(I,IC)=-1 ou 0 pas de rotation 322 : 323 : SEGACT MCHPO1 324 : DO 16 I=1,MCHPO1.IPCHP(/1) 325 : MSOUP3=MCHPO1.IPCHP(I) 326 : SEGACT MSOUP3 327 : MPOVA3=MSOUP3.IPOVAL 328 : SEGACT MPOVA3*MOD 329 : ICC1=0 330 : NC=MSOUP3.NOCOMP(/2) 331 : DO 15 IC=1,NC 332 : C si les valeurs sont deja a jour : 333 : IF(TRIGO1(I,IC).LT.0) GO TO 15 334 : C il y a TRIGO1(I,IC) ddl a traiter en meme temps: 335 : C incrementation de IC par les go to 336 : IF(IC.LT.ICC1) GO TO 15 337 : ICC1=IC+TRIGO1(I,IC) 338 : N=MPOVA3.VPOCHA(/1) 339 : DO IB=1,N 340 : XD=MPOVA3.VPOCHA(IB, IC) 341 : YD=MPOVA3.VPOCHA(IB, IC+1) 342 : ZD=0. 343 : IF(IFOUR.EQ.2)ZD=MPOVA3.VPOCHA(IB,IC+2) 344 : CO=COS(ANGLE) 345 : SI=SIN(ANGLE) 346 : XE=XD*XV1+YD*YV1+ZD*ZV1 347 : YE=XD*XV2+YD*YV2+ZD*ZV2 348 : ZE=XD*XVEC+YD*YVEC+ZD*ZVEC 349 : XD=XE*CO-YE*SI 350 : YD=XE*SI+YE*CO 351 : ZD=ZE 352 : c nouveaux ux uy uz= 353 : MPOVA3.VPOCHA(IB,IC) =XD*XV1+YD*XV2+ZD*XVEC 354 : MPOVA3.VPOCHA(IB,IC+1)=XD*YV1+YD*YV2+ZD*YVEC 355 : IF(IFOUR.EQ.2) 356 : #MPOVA3.VPOCHA(IB,IC+2)=XD*ZV1+YD*ZV2+ZD*ZVEC 357 : ENDDO 358 : 15 CONTINUE 359 : SEGDES MSOUP3,MPOVA3 360 : 16 CONTINUE 361 : SEGDES MSWBL1 362 : 363 : C ** partition 364 : C initialisation et ajustement du segment MTRAV 365 : NNIN=0 366 : NNNOE=0 367 : SEGINI,MTRAV 368 : 369 : C tri des composantes: elles ne doivent apparaitre 370 : C qu' 1 seule fois dans INCO 371 : DO 22 I=1,MCHPO1.IPCHP(/1) 372 : MSOUP3=MCHPO1.IPCHP(I) 373 : SEGACT MSOUP3 374 : NC=MSOUP3.NOCOMP(/2) 375 : DO 21 IA=1,NC 376 : MOIC=MSOUP3.NOCOMP(IA) 377 : IF(NNIN.EQ.0)THEN 378 : NNIN=1 379 : SEGADJ,MTRAV 380 : INCO(NNIN)= MOIC 381 : ELSE 382 : LAG=.TRUE. 383 : DO IAA=1,NNIN 384 : IF(MOIC.EQ.INCO(IAA))THEN 385 : LAG=.FALSE. 386 : GO TO 17 387 : ENDIF 388 : ENDDO 389 : 17 CONTINUE 390 : IF(LAG)THEN 391 : NNIN=NNIN + 1 392 : SEGADJ,MTRAV 393 : INCO(NNIN)=MOIC 394 : ENDIF 395 : ENDIF 396 : 21 CONTINUE 397 : SEGDES MSOUP3 398 : 22 CONTINUE 399 : C fin tri des composantes 400 : 401 : C on passe de la numerotation globale a 402 : C la numerotation locale 403 : SEGINI ICPR 404 : DO 25 I=1,MCHPO1.IPCHP(/1) 405 : MSOUP3=MCHPO1.IPCHP(I) 406 : SEGACT MSOUP3 407 : NC=MSOUP3.NOCOMP(/2) 408 : DO 24 IA=1,NC 409 : MELEME=MSOUP3.IGEOC 410 : SEGACT MELEME 411 : DO IAA=1,NUM(/2) 412 : IAB =NUM(1,IAA) 413 : ICPR(IAB)= 1 414 : ENDDO 415 : SEGDES MELEME 416 : 24 CONTINUE 417 : SEGDES MSOUP3 418 : 25 CONTINUE 419 : 420 : NNNOE=0 421 : DO I=1,ICPR(/1) 422 : IF(ICPR(I).EQ.1) THEN 423 : NNNOE= NNNOE+1 424 : SEGADJ MTRAV 425 : ICPR(I)=NNNOE 426 : IGEO(NNNOE)=I 427 : ENDIF 428 : ENDDO 429 : C fin numerotation locale 430 : C NNNOE et NNNIN sont aux bonnes tailles et valeurs 431 : 432 : C copie des valeurs aux noeuds + mise a jour de IBIN et NHAR 433 : C attention a la correspondance entre la composante en cours 434 : C de traitement et son homologue rangee dans INCO 435 : DO 30 I=1,MCHPO1.IPCHP(/1) 436 : MSOUP3=MCHPO1.IPCHP(I) 437 : SEGACT MSOUP3 438 : DO 29 IAB=1,MSOUP3.NOCOMP(/2) 439 : MOIC=MSOUP3.NOCOMP(IAB) 440 : MELEME=MSOUP3.IGEOC 441 : MPOVA3=MSOUP3.IPOVAL 442 : SEGACT MELEME,MPOVA3 443 : DO 28 IA=1,NUM(/2) 444 : DO IB=1,NNIN 445 : IF (MOIC.EQ.INCO(IB)) THEN 446 : BB(IB,ICPR(NUM(1,IA)))=MPOVA3.VPOCHA(IA,IAB) 447 : IBIN(IB,ICPR(NUM(1,IA)))=1 448 : NHAR(IB)=MSOUP3.NOHARM(IAB) 449 : ELSE 450 : CONTINUE 451 : ENDIF 452 : ENDDO 453 : 28 CONTINUE 454 : SEGDES MPOVA3,MELEME 455 : 29 CONTINUE 456 : SEGDES MSOUP3 457 : 30 CONTINUE 458 : 459 : C le segment MTRAV est entierement rempli 460 : C on l envoie a crechep 460 : CALL CRECHP(MTRAV,KCHPOI) 461 : IP1 = KCHPOI 462 : GOTO 992 463 : 464 : c cas du mchaml 465 : 200 CONTINUE 466 : MCHEL1 = IP1 467 : 468 : C creation matrice aaa 4 col 6 lignes 469 : DO I=1,6 470 : AAA(1,I)=MOCONT(I) 471 : AAA(2,I)=MODEFO(I) 472 : AAA(3,I)=MOCONT(I) 473 : AAA(4,I)=MODEFO(I) 474 : ENDDO 475 : 476 : NBMDDL=0 477 : LDDLA=0 478 : SEGACT MCHEL1 479 : IZO=MCHEL1.ICHAML(/1) 480 : NOCO=0 481 : SEGINI MSWBLO,MSWBL1 482 : DO 208 I=1,MCHEL1.ICHAML(/1) 483 : NOC=0 484 : MCHAM1=MCHEL1.ICHAML(I) 485 : SEGACT MCHAM1 486 : DO 207 IA=1,MCHAM1.NOMCHE(/2) 487 : MOIC=MCHAM1.NOMCHE(IA) 488 : TYPIC=MCHAM1.TYPCHE(IA) 489 : C B-1):lecture de chpo1 et test si correspondance entre 490 : C la composante moic du chpo1 et une du tableau aaa 491 : C si oui LAG vrai 492 : * controle que le type est bien reel 493 : LAG=.FALSE. 494 : DO 203 ICO=1,4 495 : DO 203 ILIGN=1,6 496 : LAG=(MOIC.EQ.AAA(ICO,ILIGN)).AND.(TYPIC.EQ.'REAL*8') 497 : IF (LAG) THEN 498 : ICOL=ICO 499 : GO TO 204 500 : ENDIF 501 : 203 CONTINUE 502 : 204 CONTINUE 503 : 504 : IF (LAG) THEN 505 : IF(NOC.GE.1) THEN 506 : C la composante est elle deja existante dans cette zone? 507 : DO IAK= 1 ,NOCO 508 : IF(MOIC.EQ.MOZO(I,IAK)) GO TO 207 509 : ENDDO 510 : ENDIF 511 : 512 : C en sortie de boucle icol represente le type de ddl: 513 : C icol =1 --> CONT massif, icol =2 --> DEFO massif 514 : C icol =3 --> CONT, icol =4 --> DEFO, 515 : 516 : C B-2) determination du nombre et de l appellation des composantes 517 : C a creer pour le mchaml tourne selon type de calcul 518 : C initialisations de depart 519 : LDDLA=0 520 : IPOSIA=0 521 : IF(IFOUR.NE.-2.AND.IFOUR.NE.-1.AND.IFOUR.NE.-3) GOTO 211 522 : 523 : C DEFORMATIONS PLANES OU CONTRAINTES PLANES OU DEF PLANE GENE 524 : C DEFO PLAN -1: UX UY / SMXX SMYY SMZZ SMXY 525 : C OU CONT PLAN -2: UX UY / idem 526 : C OU DEF PLANE GENE -3:UX UY UZ / idem 527 : LDDLA=4 528 : IPOSIA=0 529 : GOTO 217 530 : 211 CONTINUE 531 : IF(IFOUR.NE.0) GOTO 212 532 : C 533 : C AXISYMETRIQUE (IFOUR= 0) 534 : C UR UZ / SMRR SMTT SMZZ SMRZ 535 : LDDLA=4 536 : IPOSIA=3 537 : GOTO 217 538 : 212 CONTINUE 539 : IF(IFOUR.NE.1) GOTO 213 540 : C 541 : C FOURIER (IFOUR= 1 ) 542 : C UR UZ / SMXX SMYY SMZZ SMXY ? 543 : LDDLA=4 544 : IPOSIA=3 545 : GOTO 217 546 : 213 CONTINUE 547 : IF(IFOUR.NE.2) GOTO 214 548 : C 549 : C TRIDIM (IFOUR= 2 ) 550 : C UX UY UZ / SMXX SMYY SMZZ SMXY SMXZ SMYZ 551 : LDDLA=6 552 : IPOSIA=0 553 : GOTO 217 554 : 214 CONTINUE 555 : C 556 : C DEFORMATIONS GENERALISEES 557 : LDDLA=0 558 : LDDLB=0 559 : IPOSIA=0 560 : IPOSIB=0 561 : 217 CONTINUE 562 : C 563 : IF ((NOC+LDDLA).GT.NOCO) THEN 564 : NOCO=NOC+LDDLA 565 : SEGADJ MSWBL1 566 : ENDIF 567 : 568 : C la composante envoyee est elle compatible avec le mode de calcul?? 569 : DO IAA=1,LDDLA 570 : * on semble impose les composantes du champ resultat : pb melange 571 : IF(MOIC.EQ.AAA(ICOL,IPOSIA+IAA)) THEN 572 : GO TO 218 573 : ELSE 574 : IF(IAA.EQ.LDDLA)THEN 575 : IF(IFOUR.EQ.-1)MESSER='DEFO PLAN ' 576 : IF(IFOUR.EQ.-2)MESSER='CONT PLAN ' 577 : IF(IFOUR.EQ.-3)MESSER='DEF PLANE GENE' 578 : IF(IFOUR.EQ.0)MESSER='AXISYMETRIQUE ' 579 : IF(IFOUR.EQ.1)MESSER='FOURIER ' 580 : IF(IFOUR.EQ.2)MESSER='TRIDIM ' 581 : INTERR(1)=I 582 : MOTERR(1:4)=MOIC 583 : MOTERR(5:19)=MESSER 584 : * 584 : CALL ERREUR (805) 585 : GO TO 994 586 : ELSE 587 : CONTINUE 588 : ENDIF 589 : ENDIF 590 : ENDDO 591 : 218 CONTINUE 592 : 593 : C on remplit motddl 594 : DO IAA=1,LDDLA 595 : MOTDDL(**)=AAA(ICOL,IPOSIA+IAA) 596 : ENDDO 597 : 598 : C remplissage des tableaux,MOZO,TRIGO1 et NOCCH1 599 : C qui serviront a dimensionner le nouveau mchaml 600 : 601 : C MOZO contient pour chaque zone le nom des composantes 602 : C et peut aussi....contenir du ' 'ce qui servira. 603 : 604 : C NOCCH1 contient,pour chaque zone, le no d emplacement de 605 : C chaque composante dans le mchaml d origine. si une composante 606 : C cree n existait pas dans le mchaml de depart alors: 607 : C NOCCH1 (zone,no compos)=0 608 : 609 : C TRIGO1 contient,pour chaque zone,et pour chaque composante 610 : C un nombre qui peut prendre les valeurs: 611 : C -1 si la composante ne doit pas tourner 612 : C 0 si MOZO (I,nomcompos) =' ' 613 : C 3 2 ou 1 si elle doit tourner.la 1ere des composantes d une meme 614 : C famille est indicee a 2 (3 si 3d). 615 : 616 : IF ((NOC+LDDLA).GT.NOCO) THEN 617 : NOCO=NOC+LDDLA 618 : SEGADJ MSWBL1 619 : ENDIF 620 : DO 206 IAA=NBMDDL+1,NBMDDL+LDDLA 621 : NOC= NOC+1 622 : MOZO (I,NOC)=MOTDDL(IAA) 623 : TRIGO1(I,NOC)=NBMDDL+LDDLA+1-IAA 624 : 625 : DO 205 IAB=IA,MCHAM1.NOMCHE(/2) 626 : IF(MOTDDL(IAA).EQ.MCHAM1.NOMCHE(IAB))THEN 627 : NOCCH1 (I,NOC)=IAB 628 : ELSE 629 : IF(.NOT.LAG)NOCCH1 (I,NOC)=0 630 : ENDIF 631 : 205 CONTINUE 632 : 206 CONTINUE 633 : NBMDDL=NBMDDL+LDDLA 634 : 635 : ELSE 636 : NOC= NOC + 1 637 : IF (NOC.GT.NOCO) THEN 638 : NOCO= NOCO + 1 639 : SEGADJ MSWBL1 640 : ENDIF 641 : MOZO(I,NOC)=MOIC 642 : NOCCH1(I,NOC)=IA 643 : TRIGO1(I,NOC)=-1 644 : 645 : ENDIF 646 : 207 CONTINUE 647 : SEGDES MCHAM1 648 : 208 CONTINUE 649 : SEGDES MSWBLO 650 : 651 : C mise a jour des valeurs de toutes les composantes du 652 : C nouveau mchaml sans tenir compte des rotations 653 : SEGACT, MCHEL1*MOD 654 : DO 224 I=1,MCHEL1.ICHAML(/1) 655 : MCHAM1=MCHEL1.ICHAML(I) 656 : DO NC=1,NOCCH1(/2) 657 : IF(MOZO(I,NC).EQ.' ')GO TO 221 658 : ENDDO 659 : 221 CONTINUE 660 : N2=NC-1 661 : SEGINI MCHAM3 662 : MCHEL1.ICHAML(I)=MCHAM3 663 : * chercher le dimensionnement max et apres tout faire ... 664 : N1PTEL = 1 665 : N1EL = 1 666 : SEGACT MCHAM1 667 : DO KN2=1,MCHAM1.IELVAL(/1) 668 : MELVA1 = MCHAM1.IELVAL(KN2) 669 : SEGACT MELVA1 670 : N1PTEL = MAX(MELVA1.VELCHE(/1),N1PTEL) 671 : N1EL = MAX(MELVA1.VELCHE(/2),N1EL) 672 : SEGDES MELVA1 673 : ENDDO 674 : DO 223 IC = 1,N2 675 : MCHAM3.NOMCHE(IC)=MOZO(I,IC) 676 : ICN= NOCCH1(I,IC) 677 : IF(ICN.EQ.0) THEN 678 : C si composante n existe pas dans le mchaml initial 679 : C (car elle est cree pour mchel3) elle reste a 0 680 : N2PTEL=0 681 : N2EL=0 682 : SEGINI MELVA3 683 : MCHAM3.IELVAL(IC) = MELVA3 684 : MCHAM3.TYPCHE(IC) = 'REAL*8' 685 : SEGDES MELVA3 686 : GOTO 223 687 : ENDIF 688 : c la composante existe 689 : MELVA1=MCHAM1.IELVAL(ICN) 690 : MCHAM3.TYPCHE(IC) = MCHAM1.TYPCHE(ICN) 691 : IF (MCHAM1.TYPCHE(ICN).NE.'REAL*8') THEN 692 : MCHAM3.IELVAL(IC) = MELVA1 693 : GOTO 223 694 : ENDIF 695 : SEGACT MELVA1 696 : N2PTEL=0 697 : N2EL=0 698 : SEGINI MELVA3 699 : MCHAM3.IELVAL(IC)=MELVA3 700 : DO INPT = 1,N1PTEL 701 : DO IEL = 1,N1EL 702 : IF (MELVA1.VELCHE(/1).EQ.1) THEN 703 : IF (MELVA1.VELCHE(/2).EQ.1) THEN 704 : MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(1,1) 705 : ELSE 706 : MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(1,IEL) 707 : ENDIF 708 : ELSE 709 : MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(INPT,IEL) 710 : ENDIF 711 : ENDDO 712 : ENDDO 713 : SEGSUP MELVA1 714 : SEGDES MELVA3 715 : 223 CONTINUE 716 : SEGSUP MCHAM1 717 : SEGDES MCHAM3 718 : 224 CONTINUE 719 : SEGDES MCHEL1 720 : C fin mise a jour des valeurs sans rotations 721 : 722 : * determine QRtQ 723 : CO=COS(ANGLE) 724 : SI=SIN(ANGLE) 725 : RtQ(1,1) = CO*XV1 - SI*XV2 726 : RtQ(1,2) = CO*YV1 - SI*YV2 727 : RtQ(1,3) = CO*ZV1 - SI*ZV2 728 : RtQ(2,1) = SI*XV1 + CO*XV2 729 : RtQ(2,2) = SI*YV1 + CO*YV2 730 : RtQ(2,3) = SI*ZV1 + CO*ZV2 731 : RtQ(3,1) = XVEC 732 : RtQ(3,2) = YVEC 733 : RtQ(3,3) = ZVEC 734 : 735 : QRtQ(1,1) = XV1*RtQ(1,1) + XV2*RtQ(2,1) + XVEC*RtQ(3,1) 736 : QRtQ(1,2) = XV1*RtQ(1,2) + XV2*RtQ(2,2) + XVEC*RtQ(3,2) 737 : QRtQ(1,3) = XV1*RtQ(1,3) + XV2*RtQ(2,3) + XVEC*RtQ(3,3) 738 : QRtQ(2,1) = YV1*RtQ(1,1) + YV2*RtQ(2,1) + YVEC*RtQ(3,1) 739 : QRtQ(2,2) = YV1*RtQ(1,2) + YV2*RtQ(2,2) + YVEC*RtQ(3,2) 740 : QRtQ(2,3) = YV1*RtQ(1,3) + YV2*RtQ(2,3) + YVEC*RtQ(3,3) 741 : QRtQ(3,1) = ZV1*RtQ(1,1) + ZV2*RtQ(2,1) + ZVEC*RtQ(3,1) 742 : QRtQ(3,2) = ZV1*RtQ(1,2) + ZV2*RtQ(2,2) + ZVEC*RtQ(3,2) 743 : QRtQ(3,3) = ZV1*RtQ(1,3) + ZV2*RtQ(2,3) + ZVEC*RtQ(3,3) 744 : 745 : C mise a jour des valeurs des composantes du 746 : C nouveau mchaml necessitant la rotation 747 : C TRIGO1(I,IC)= 1 , 2 , 3 au max; 748 : C TRIGO1(I,IC)=-1 ou 0 pas de rotation 749 : SEGACT MCHEL1 750 : DO 236 I=1,MCHEL1.ICHAML(/1) 751 : MCHAM3=MCHEL1.ICHAML(I) 752 : SEGACT MCHAM3 753 : ICC1=0 754 : NC=MCHAM3.NOMCHE(/2) 755 : DO 235 IC=1,NC 756 : C si les valeurs sont deja a jour : 757 : IF(TRIGO1(I,IC).LT.0) GO TO 235 758 : C il y a TRIGO1(I,IC) ddl a traiter en meme temps: 759 : C incrementation de IC par les go to 760 : IF(IC.LT.ICC1) GO TO 235 761 : ICC1=IC+TRIGO1(I,IC) 762 : * calcul plan, axi ou Fourier 763 : MELVA1=MCHAM3.IELVAL(IC) 764 : MELVA2=MCHAM3.IELVAL(IC+1) 765 : MELVA3=MCHAM3.IELVAL(IC+2) 766 : MELVA4=MCHAM3.IELVAL(IC+3) 767 : SEGACT, MELVA1*MOD,MELVA2*MOD,MELVA3*MOD,MELVA4*MOD 768 : * calcul 3D 769 : IF (TRIGO1(I,IC).EQ.6) THEN 770 : MELVA5=MCHAM3.IELVAL(IC+4) 771 : MELVA6=MCHAM3.IELVAL(IC+5) 772 : SEGACT, MELVA5*MOD,MELVA6*MOD 773 : ENDIF 774 : N1PTEL=MELVA1.VELCHE(/1) 775 : N1EL = MELVA1.VELCHE(/2) 776 : DO INPT = 1,N1PTEL 777 : DO IEL = 1,N1EL 778 : SIGM(1,1)=MELVA1.VELCHE(INPT,IEL) 779 : SIGM(2,2)=MELVA2.VELCHE(INPT,IEL) 780 : SIGM(1,2)=MELVA4.VELCHE(INPT,IEL) 781 : SIGM(2,1)=SIGM(1,2) 782 : SIGM(3,3)=MELVA3.VELCHE(INPT,IEL) 783 : IF (TRIGO1(I,IC).EQ.6) THEN 784 : SIGM(1,3)=MELVA5.VELCHE(INPT,IEL) 785 : SIGM(2,3)=MELVA6.VELCHE(INPT,IEL) 786 : SIGM(3,1)=SIGM(1,3) 787 : SIGM(3,2)=SIGM(2,3) 788 : ELSE 789 : SIGM(1,3)=0 790 : SIGM(2,3)=0 791 : SIGM(3,1)=0 792 : SIGM(3,2)=0 793 : ENDIF 794 : c nouvelles composantes = QRtQ SIGMA QtRtQ 795 : DO L=1,3 796 : DO M=1,3 797 : NSIG(L,M)=SIGM(L,1)*QRtQ(M,1)+SIGM(L,2)*QRtQ(M,2)+ 798 : & SIGM(L,3)*QRtQ(M,3) 799 : ENDDO 800 : ENDDO 801 : DO L=1,3 802 : DO M=1,3 803 : SIGM(L,M)=NSIG(1,M)*QRtQ(L,1)+NSIG(2,M)*QRtQ(L,2)+ 804 : & NSIG(3,M)*QRtQ(L,3) 805 : ENDDO 806 : ENDDO 807 : MELVA1.VELCHE(INPT,IEL)=SIGM(1,1) 808 : MELVA2.VELCHE(INPT,IEL)=SIGM(2,2) 809 : MELVA4.VELCHE(INPT,IEL)=SIGM(1,2) 810 : MELVA3.VELCHE(INPT,IEL)=SIGM(3,3) 811 : IF (TRIGO1(I,IC).EQ.6) THEN 812 : MELVA5.VELCHE(INPT,IEL)=SIGM(1,3) 813 : MELVA6.VELCHE(INPT,IEL)=SIGM(2,3) 814 : ENDIF 815 : ENDDO 816 : ENDDO 817 : SEGDES, MELVA1,MELVA2,MELVA3,MELVA4 818 : IF (TRIGO1(I,IC).EQ.6) SEGDES, MELVA5,MELVA6 819 : 235 CONTINUE 820 : SEGDES MCHAM3 821 : 236 CONTINUE 822 : SEGDES MSWBL1 823 : 824 : * on arrete la le traitement. Par rapport a la programmation 825 : * du cas chpoint, il y a encore des verifs a faire sur l unicite 826 : * des composantes. Mais comme a ce jour, la definition du ET sur 827 : * les MCHAML n est pas claire, il faut reflechir ... 11/97 KICH. 828 : SEGDES MCHEL1 829 : IP1 = MCHEL1 830 : GOTO 994 831 : 832 : 992 CONTINUE 833 : SEGSUP MTRAV,ICPR 834 : 994 CONTINUE 835 : SEGSUP MSWBLO, MSWBL1 836 : 999 CONTINUE 837 : RETURN 838 : END 839 : 840 : 841 : 842 : 843 : 844 :
© Cast3M 2003 - All rights reserved.
Disclaimer