C TOCH1 SOURCE SP204843 25/03/14 21:15:10 12201 C TOCH1 C CE SOUS PROGRAMME EST APPELE PAR PROPER. C IL GERE LA ROTATION DES COMPOSANTES DES CHPOINT, MCHAML C SOURCE MO + CHARRAS 97/07/29 C MODIF KICH 97/11 C les differentes etapes sont commentees le long du programme. SUBROUTINE TOCH1 (IP1,MOTYPE,IRETO) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMELEME -INC SMCHPOI -INC SMCHAML -INC TMTRAV -INC CCGEOME -INC CCTOURN REAL*8 SIGM(3,3),QRtQ(3,3),NSIG(3,3),RtQ(3,3) CHARACTER*(LOCOMP) MOIC CHARACTER*8 MOTYPE CHARACTER*14 MESSER CHARACTER*16 TYPIC LOGICAL LAG SEGMENT ICPR(nbpts) SEGMENT MSWBLO CHARACTER*(LOCOMP) MOTDDL(0) ENDSEGMENT SEGMENT MSWBL1 CHARACTER*(LOCOMP) MOZO(IZO,NOCO) INTEGER NOCCH1(IZO,NOCO) INTEGER TRIGO1(IZO,NOCO) ENDSEGMENT * CHARACTER*(LOCOMP) AAA(4,6) CHARACTER*(LOCOMP) MODEPL(5) CHARACTER*(LOCOMP) MODEDU(5) CHARACTER*(LOCOMP) MORODU(5) CHARACTER*(LOCOMP) MOROTA(5) CHARACTER*(LOCOMP) MOCONT(6) CHARACTER*(LOCOMP) MODEFO(6) C AAA(1,..) DATA MODEPL(1)/'UX '/ DATA MODEPL(2)/'UY '/ DATA MODEPL(3)/'UZ '/ DATA MODEPL(4)/'UR '/ DATA MODEPL(5)/'UZ '/ C DATA MODEPL(6)/'UT '/ C AAA(2,..) DATA MODEDU(1)/'FX '/ DATA MODEDU(2)/'FY '/ DATA MODEDU(3)/'FZ '/ DATA MODEDU(4)/'FR '/ DATA MODEDU(5)/'FZ '/ C AAA(3,..) DATA MOROTA(1)/'RX '/ DATA MOROTA(2)/'RY '/ DATA MOROTA(3)/'RZ '/ DATA MOROTA(4)/' '/ DATA MOROTA(5)/' '/ C AAA(4,..) DATA MORODU(1)/'MX '/ DATA MORODU(2)/'MY '/ DATA MORODU(3)/'MZ '/ DATA MORODU(4)/' '/ DATA MORODU(5)/' '/ DATA MOCONT(1)/'SMXX'/ DATA MOCONT(2)/'SMYY'/ DATA MOCONT(3)/'SMZZ'/ DATA MOCONT(4)/'SMXY'/ DATA MOCONT(5)/'SMXZ'/ DATA MOCONT(6)/'SMYZ'/ C DATA MODEFO(1)/'EPXX'/ DATA MODEFO(2)/'EPYY'/ DATA MODEFO(3)/'EPZZ'/ DATA MODEFO(4)/'GAXY'/ DATA MODEFO(5)/'GAXZ'/ DATA MODEFO(6)/'GAYZ'/ C IF (MOTYPE.EQ.'CHPOINT ') GOTO 100 IF (MOTYPE.EQ.'MCHAML ') GOTO 200 100 CONTINUE MCHPO1 = IP1 C creation matrice aaa 4 col 5 lignes DO I=1,5 AAA(1,I)=MODEPL(I) AAA(2,I)=MODEDU(I) AAA(3,I)=MOROTA(I) AAA(4,I)=MORODU(I) ENDDO NBMDDL=0 LDDLA=0 SEGACT MCHPO1 IZO=MCHPO1.IPCHP(/1) NOCO=0 SEGINI MSWBLO,MSWBL1 DO 8 I=1,MCHPO1.IPCHP(/1) NOC=0 MSOUP1=MCHPO1.IPCHP(I) SEGACT MSOUP1 DO 7 IA=1,MSOUP1.NOCOMP(/2) MOIC=MSOUP1.NOCOMP(IA) C B-1):lecture de chpo1 et test si correspondance entre C la composante moic du chpo1 et une du tableau aaa C si oui LAG vrai LAG=.FALSE. DO 3 ICO=1,4 DO 31 ILIGN=1,6 LAG=(MOIC.EQ.AAA(ICO,ILIGN)) IF (LAG) THEN ICOL=ICO GO TO 4 ENDIF 31 CONTINUE 3 CONTINUE 4 CONTINUE IF (LAG) THEN IF(NOC.GE.1) THEN C la composante est elle deja existante dans cette zone? DO IAK= 1 ,NOCO IF(MOIC.EQ.MOZO(I,IAK)) GO TO 7 ENDDO ENDIF C en sortie de boucle ico represente le type de ddl: C icol =1 --> DEPL, ico =2 --> FORCES C icol =3 --> ROTA, ico =4 --> MOMENT C B-2) determination du nombre et de l appellation des ddl C a creer pour le chpo tourne selon type de calcul C initialisations de depart LDDLA=0 IPOSIA=0 IF(IFOUR.NE.-2.AND.IFOUR.NE.-1.AND.IFOUR.NE.-3) GOTO 101 C DEFORMATIONS PLANES OU CONTRAINTES PLANES OU DEF PLANE GENE C DEFO PLAN -1: UX UY C OU CONT PLAN -2: UX UY C OU DEF PLANE GENE -3:UX UY UZ LDDLA=2 IPOSIA=0 GOTO 107 101 CONTINUE IF(IFOUR.NE.0) GOTO 102 C C AXISYMETRIQUE (IFOUR= 0) C UR UZ LDDLA=2 IPOSIA=3 GOTO 107 102 CONTINUE IF(IFOUR.NE.1) GOTO 103 C C FOURIER (IFOUR= 1 ) C UR UZ LDDLA=2 IPOSIA=3 GOTO 107 103 CONTINUE IF(IFOUR.NE.2) GOTO 104 C C TRIDIM (IFOUR= 2 ) C UX UY UZ C FX FY FZ C RX RY RZ C MX MY MZ LDDLA=3 IPOSIA=0 GOTO 107 104 CONTINUE C C DEFORMATIONS GENERALISEES LDDLA=0 LDDLB=0 IPOSIA=0 IPOSIB=0 107 CONTINUE C IF ((NOC+LDDLA).GT.NOCO) THEN NOCO=NOC+LDDLA SEGADJ MSWBL1 ENDIF C la composante envoyee est elle compatible avec le mode de calcul?? DO IAA=1,LDDLA IF(MOIC.EQ.AAA(ICOL,IPOSIA+IAA)) THEN GO TO 108 ELSE IF(IAA.EQ.LDDLA)THEN IF(IFOUR.EQ.-1)MESSER='DEFO PLAN ' IF(IFOUR.EQ.-2)MESSER='CONT PLAN ' IF(IFOUR.EQ.-3)MESSER='DEF PLANE GENE' IF(IFOUR.EQ.0)MESSER='AXISYMETRIQUE ' IF(IFOUR.EQ.1)MESSER='FOURIER ' IF(IFOUR.EQ.2)MESSER='TRIDIM ' INTERR(1)=I MOTERR(1:4)=MOIC MOTERR(5:19)=MESSER CALL ERREUR (805) GO TO 999 ELSE CONTINUE ENDIF ENDIF ENDDO 108 CONTINUE C on remplit motddl DO IAA=1,LDDLA MOTDDL(**)=AAA(ICOL,IPOSIA+IAA) ENDDO C remplissage des tableaux,MOZO,TRIGO1 et NOCCH1 C qui serviront a dimensionner le nouveau chpo C MOZO contient pour chaque zone le nom des composantes C et peut aussi....contenir du ' 'ce qui servira. C NOCCH1 contient,pour chaque zone, le no d emplacement de C chaque composante dans le chpo d origine. si une composante C cree n existait pas dans le chpo de depart alors: C NOCCH1 (zone,no compos)=0 C TRIGO1 contient,pour chaque zone,et pour chaque composante C un nombre qui peut prendre les valeurs: C -1 si la composante ne doit pas tourner C 0 si MOZO (I,nomcompos) =' ' C 3 2 ou 1 si elle doit tourner.la 1ere des ddl d une meme C famille est indicee a 2 (3 si 3d). IF ((NOC + LDDLA).GT.NOCO) THEN NOCO=NOC+LDDLA SEGADJ MSWBL1 ENDIF DO 6 IAA=NBMDDL+1,NBMDDL+LDDLA NOC= NOC+1 MOZO (I,NOC)=MOTDDL(IAA) TRIGO1(I,NOC)=NBMDDL+LDDLA+1-IAA DO 5 IAB=IA,MSOUP1.NOCOMP(/2) IF(MOTDDL(IAA).EQ.MSOUP1.NOCOMP(IAB))THEN NOCCH1 (I,NOC)=IAB ELSE IF(.NOT.LAG)NOCCH1 (I,NOC)=0 ENDIF 5 CONTINUE 6 CONTINUE NBMDDL=NBMDDL+LDDLA ELSE NOC= NOC+1 IF (NOC.GT.NOCO) THEN NOCO= NOCO+ 1 SEGADJ MSWBL1 ENDIF MOZO(I,NOC)=MOIC NOCCH1(I,NOC)=IA TRIGO1(I,NOC)=-1 ENDIF 7 CONTINUE 8 CONTINUE SEGDES MSWBLO C print*,'en sortie: ' C print*,'NOCO= ',NOCO C do iiw=1,NOCCH1 (/1) C do ijl=1,NOCCH1 (/2) C print*,'MOZO (',Iiw,',',ijl,')= ',MOZO(Iiw,ijl) C #,'NOCCH1 (',Iiw,',',ijl,')= ',NOCCH1(Iiw,ijl) C #,'TRIGO1 (',Iiw,',',ijl,')= ',TRIGO1(Iiw,ijl) C enddo C enddo C mise a jour des valeurs de toutes les composantes du C nouveau chpo1 sans tenir compte des rotations SEGACT, MCHPO1*MOD MCHPO1.IFOPOI = IFOUR DO 14 I=1,MCHPO1.IPCHP(/1) MSOUP1=MCHPO1.IPCHP(I) DO NC=1,NOCCH1(/2) IF(MOZO(I,NC).EQ.' ')GO TO 11 ENDDO 11 CONTINUE NC=NC-1 SEGINI MSOUP3 MCHPO1.IPCHP(I)=MSOUP3 SEGACT MSOUP1 MSOUP3.IGEOC= MSOUP1.IGEOC MPOVA1=MSOUP1.IPOVAL SEGACT MPOVA1 N=MPOVA1.VPOCHA(/1) SEGINI MPOVA3 MSOUP3.IPOVAL=MPOVA3 DO 13 IC=1,NC MSOUP3.NOCOMP(IC)=MOZO(I,IC) ICN= NOCCH1(I,IC) IF(ICN.EQ.0) GO TO 13 C si composante n existe pas dans le chpo initial C (car elle est cree pour chpo3) elle reste a 0 DO IB=1,N MPOVA3.VPOCHA(IB,IC)=MPOVA1.VPOCHA(IB,ICN) ENDDO 13 CONTINUE SEGSUP MPOVA1,MSOUP1 14 CONTINUE C fin mise a jour des valeurs sans rotations C mise a jour des valeurs des composantes du C nouveau chpo1 necessitant la rotation C TRIGO1(I,IC)= 1 , 2 , 3 au max; C TRIGO1(I,IC)=-1 ou 0 pas de rotation SEGACT MCHPO1 DO 16 I=1,MCHPO1.IPCHP(/1) MSOUP3=MCHPO1.IPCHP(I) SEGACT MSOUP3 MPOVA3=MSOUP3.IPOVAL SEGACT MPOVA3*MOD ICC1=0 NC=MSOUP3.NOCOMP(/2) DO 15 IC=1,NC C si les valeurs sont deja a jour : IF(TRIGO1(I,IC).LT.0) GO TO 15 C il y a TRIGO1(I,IC) ddl a traiter en meme temps: C incrementation de IC par les go to IF(IC.LT.ICC1) GO TO 15 ICC1=IC+TRIGO1(I,IC) N=MPOVA3.VPOCHA(/1) DO IB=1,N XD=MPOVA3.VPOCHA(IB, IC) YD=MPOVA3.VPOCHA(IB, IC+1) ZD=0. IF(IFOUR.EQ.2)ZD=MPOVA3.VPOCHA(IB,IC+2) CO=COS(ANGLE) SI=SIN(ANGLE) XE=XD*XV1+YD*YV1+ZD*ZV1 YE=XD*XV2+YD*YV2+ZD*ZV2 ZE=XD*XVEC+YD*YVEC+ZD*ZVEC XD=XE*CO-YE*SI YD=XE*SI+YE*CO ZD=ZE c nouveaux ux uy uz= MPOVA3.VPOCHA(IB,IC) =XD*XV1+YD*XV2+ZD*XVEC MPOVA3.VPOCHA(IB,IC+1)=XD*YV1+YD*YV2+ZD*YVEC IF(IFOUR.EQ.2) #MPOVA3.VPOCHA(IB,IC+2)=XD*ZV1+YD*ZV2+ZD*ZVEC ENDDO 15 CONTINUE 16 CONTINUE SEGDES MSWBL1 C ** partition C initialisation et ajustement du segment MTRAV NNIN=0 NNNOE=0 SEGINI,MTRAV C tri des composantes: elles ne doivent apparaitre C qu' 1 seule fois dans INCO DO 22 I=1,MCHPO1.IPCHP(/1) MSOUP3=MCHPO1.IPCHP(I) SEGACT MSOUP3 NC=MSOUP3.NOCOMP(/2) DO 21 IA=1,NC MOIC=MSOUP3.NOCOMP(IA) IF(NNIN.EQ.0)THEN NNIN=1 SEGADJ,MTRAV INCO(NNIN)= MOIC ELSE LAG=.TRUE. DO IAA=1,NNIN IF(MOIC.EQ.INCO(IAA))THEN LAG=.FALSE. GO TO 17 ENDIF ENDDO 17 CONTINUE IF(LAG)THEN NNIN=NNIN + 1 SEGADJ,MTRAV INCO(NNIN)=MOIC ENDIF ENDIF 21 CONTINUE 22 CONTINUE C fin tri des composantes C on passe de la numerotation globale a C la numerotation locale SEGINI ICPR DO 25 I=1,MCHPO1.IPCHP(/1) MSOUP3=MCHPO1.IPCHP(I) SEGACT MSOUP3 NC=MSOUP3.NOCOMP(/2) DO 24 IA=1,NC MELEME=MSOUP3.IGEOC SEGACT MELEME DO IAA=1,NUM(/2) IAB =NUM(1,IAA) ICPR(IAB)= 1 ENDDO 24 CONTINUE 25 CONTINUE NNNOE=0 DO I=1,ICPR(/1) IF(ICPR(I).EQ.1) THEN NNNOE= NNNOE+1 SEGADJ MTRAV ICPR(I)=NNNOE IGEO(NNNOE)=I ENDIF ENDDO C fin numerotation locale C NNNOE et NNNIN sont aux bonnes tailles et valeurs C copie des valeurs aux noeuds + mise a jour de IBIN et NHAR C attention a la correspondance entre la composante en cours C de traitement et son homologue rangee dans INCO DO 30 I=1,MCHPO1.IPCHP(/1) MSOUP3=MCHPO1.IPCHP(I) SEGACT MSOUP3 DO 29 IAB=1,MSOUP3.NOCOMP(/2) MOIC=MSOUP3.NOCOMP(IAB) MELEME=MSOUP3.IGEOC MPOVA3=MSOUP3.IPOVAL SEGACT MELEME,MPOVA3 DO 28 IA=1,NUM(/2) DO IB=1,NNIN IF (MOIC.EQ.INCO(IB)) THEN BB(IB,ICPR(NUM(1,IA)))=MPOVA3.VPOCHA(IA,IAB) IBIN(IB,ICPR(NUM(1,IA)))=1 NHAR(IB)=MSOUP3.NOHARM(IAB) ELSE CONTINUE ENDIF ENDDO 28 CONTINUE 29 CONTINUE 30 CONTINUE C le segment MTRAV est entierement rempli C on l envoie a crechep CALL CRECHP(MTRAV,KCHPOI) IP1 = KCHPOI GOTO 992 c cas du mchaml 200 CONTINUE MCHEL1 = IP1 C creation matrice aaa 4 col 6 lignes DO I=1,6 AAA(1,I)=MOCONT(I) AAA(2,I)=MODEFO(I) AAA(3,I)=MOCONT(I) AAA(4,I)=MODEFO(I) ENDDO NBMDDL=0 LDDLA=0 SEGACT MCHEL1 IZO=MCHEL1.ICHAML(/1) NOCO=0 SEGINI MSWBLO,MSWBL1 DO 208 I=1,MCHEL1.ICHAML(/1) NOC=0 MCHAM1=MCHEL1.ICHAML(I) SEGACT MCHAM1 DO 207 IA=1,MCHAM1.NOMCHE(/2) MOIC=MCHAM1.NOMCHE(IA) TYPIC=MCHAM1.TYPCHE(IA) C B-1):lecture de chpo1 et test si correspondance entre C la composante moic du chpo1 et une du tableau aaa C si oui LAG vrai * controle que le type est bien reel LAG=.FALSE. DO 203 ICO=1,4 DO 2031 ILIGN=1,6 LAG=(MOIC.EQ.AAA(ICO,ILIGN)).AND.(TYPIC.EQ.'REAL*8') IF (LAG) THEN ICOL=ICO GO TO 204 ENDIF 2031 CONTINUE 203 CONTINUE 204 CONTINUE IF (LAG) THEN IF(NOC.GE.1) THEN C la composante est elle deja existante dans cette zone? DO IAK= 1 ,NOCO IF(MOIC.EQ.MOZO(I,IAK)) GO TO 207 ENDDO ENDIF C en sortie de boucle icol represente le type de ddl: C icol =1 --> CONT massif, icol =2 --> DEFO massif C icol =3 --> CONT, icol =4 --> DEFO, C B-2) determination du nombre et de l appellation des composantes C a creer pour le mchaml tourne selon type de calcul C initialisations de depart LDDLA=0 IPOSIA=0 IF(IFOUR.NE.-2.AND.IFOUR.NE.-1.AND.IFOUR.NE.-3) GOTO 211 C DEFORMATIONS PLANES OU CONTRAINTES PLANES OU DEF PLANE GENE C DEFO PLAN -1: UX UY / SMXX SMYY SMZZ SMXY C OU CONT PLAN -2: UX UY / idem C OU DEF PLANE GENE -3:UX UY UZ / idem LDDLA=4 IPOSIA=0 GOTO 217 211 CONTINUE IF(IFOUR.NE.0) GOTO 212 C C AXISYMETRIQUE (IFOUR= 0) C UR UZ / SMRR SMTT SMZZ SMRZ LDDLA=4 IPOSIA=3 GOTO 217 212 CONTINUE IF(IFOUR.NE.1) GOTO 213 C C FOURIER (IFOUR= 1 ) C UR UZ / SMXX SMYY SMZZ SMXY ? LDDLA=4 IPOSIA=3 GOTO 217 213 CONTINUE IF(IFOUR.NE.2) GOTO 214 C C TRIDIM (IFOUR= 2 ) C UX UY UZ / SMXX SMYY SMZZ SMXY SMXZ SMYZ LDDLA=6 IPOSIA=0 GOTO 217 214 CONTINUE C C DEFORMATIONS GENERALISEES LDDLA=0 LDDLB=0 IPOSIA=0 IPOSIB=0 217 CONTINUE C IF ((NOC+LDDLA).GT.NOCO) THEN NOCO=NOC+LDDLA SEGADJ MSWBL1 ENDIF C la composante envoyee est elle compatible avec le mode de calcul?? DO IAA=1,LDDLA * on semble impose les composantes du champ resultat : pb melange IF(MOIC.EQ.AAA(ICOL,IPOSIA+IAA)) THEN GO TO 218 ELSE IF(IAA.EQ.LDDLA)THEN IF(IFOUR.EQ.-1)MESSER='DEFO PLAN ' IF(IFOUR.EQ.-2)MESSER='CONT PLAN ' IF(IFOUR.EQ.-3)MESSER='DEF PLANE GENE' IF(IFOUR.EQ.0)MESSER='AXISYMETRIQUE ' IF(IFOUR.EQ.1)MESSER='FOURIER ' IF(IFOUR.EQ.2)MESSER='TRIDIM ' INTERR(1)=I MOTERR(1:4)=MOIC MOTERR(5:19)=MESSER * CALL ERREUR (805) GO TO 994 ELSE CONTINUE ENDIF ENDIF ENDDO 218 CONTINUE C on remplit motddl DO IAA=1,LDDLA MOTDDL(**)=AAA(ICOL,IPOSIA+IAA) ENDDO C remplissage des tableaux,MOZO,TRIGO1 et NOCCH1 C qui serviront a dimensionner le nouveau mchaml C MOZO contient pour chaque zone le nom des composantes C et peut aussi....contenir du ' 'ce qui servira. C NOCCH1 contient,pour chaque zone, le no d emplacement de C chaque composante dans le mchaml d origine. si une composante C cree n existait pas dans le mchaml de depart alors: C NOCCH1 (zone,no compos)=0 C TRIGO1 contient,pour chaque zone,et pour chaque composante C un nombre qui peut prendre les valeurs: C -1 si la composante ne doit pas tourner C 0 si MOZO (I,nomcompos) =' ' C 3 2 ou 1 si elle doit tourner.la 1ere des composantes d une meme C famille est indicee a 2 (3 si 3d). IF ((NOC+LDDLA).GT.NOCO) THEN NOCO=NOC+LDDLA SEGADJ MSWBL1 ENDIF DO 206 IAA=NBMDDL+1,NBMDDL+LDDLA NOC= NOC+1 MOZO (I,NOC)=MOTDDL(IAA) TRIGO1(I,NOC)=NBMDDL+LDDLA+1-IAA DO 205 IAB=IA,MCHAM1.NOMCHE(/2) IF(MOTDDL(IAA).EQ.MCHAM1.NOMCHE(IAB))THEN NOCCH1 (I,NOC)=IAB ELSE IF(.NOT.LAG)NOCCH1 (I,NOC)=0 ENDIF 205 CONTINUE 206 CONTINUE NBMDDL=NBMDDL+LDDLA ELSE NOC= NOC + 1 IF (NOC.GT.NOCO) THEN NOCO= NOCO + 1 SEGADJ MSWBL1 ENDIF MOZO(I,NOC)=MOIC NOCCH1(I,NOC)=IA TRIGO1(I,NOC)=-1 ENDIF 207 CONTINUE 208 CONTINUE SEGDES MSWBLO C mise a jour des valeurs de toutes les composantes du C nouveau mchaml sans tenir compte des rotations SEGACT, MCHEL1*MOD DO 224 I=1,MCHEL1.ICHAML(/1) MCHAM1=MCHEL1.ICHAML(I) DO NC=1,NOCCH1(/2) IF(MOZO(I,NC).EQ.' ')GO TO 221 ENDDO 221 CONTINUE N2=NC-1 SEGINI MCHAM3 MCHEL1.ICHAML(I)=MCHAM3 * chercher le dimensionnement max et apres tout faire ... N1PTEL = 1 N1EL = 1 SEGACT MCHAM1 DO KN2=1,MCHAM1.IELVAL(/1) MELVA1 = MCHAM1.IELVAL(KN2) SEGACT MELVA1 N1PTEL = MAX(MELVA1.VELCHE(/1),N1PTEL) N1EL = MAX(MELVA1.VELCHE(/2),N1EL) ENDDO DO 223 IC = 1,N2 MCHAM3.NOMCHE(IC)=MOZO(I,IC) ICN= NOCCH1(I,IC) IF(ICN.EQ.0) THEN C si composante n existe pas dans le mchaml initial C (car elle est cree pour mchel3) elle reste a 0 N2PTEL=0 N2EL=0 SEGINI MELVA3 MCHAM3.IELVAL(IC) = MELVA3 MCHAM3.TYPCHE(IC) = 'REAL*8' GOTO 223 ENDIF c la composante existe MELVA1=MCHAM1.IELVAL(ICN) MCHAM3.TYPCHE(IC) = MCHAM1.TYPCHE(ICN) IF (MCHAM1.TYPCHE(ICN).NE.'REAL*8') THEN MCHAM3.IELVAL(IC) = MELVA1 GOTO 223 ENDIF SEGACT MELVA1 N2PTEL=0 N2EL=0 SEGINI MELVA3 MCHAM3.IELVAL(IC)=MELVA3 DO INPT = 1,N1PTEL DO IEL = 1,N1EL IF (MELVA1.VELCHE(/1).EQ.1) THEN IF (MELVA1.VELCHE(/2).EQ.1) THEN MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(1,1) ELSE MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(1,IEL) ENDIF ELSE MELVA3.VELCHE(INPT,IEL) = MELVA1.VELCHE(INPT,IEL) ENDIF ENDDO ENDDO SEGSUP MELVA1 223 CONTINUE SEGSUP MCHAM1 224 CONTINUE C fin mise a jour des valeurs sans rotations * determine QRtQ CO=COS(ANGLE) SI=SIN(ANGLE) RtQ(1,1) = CO*XV1 - SI*XV2 RtQ(1,2) = CO*YV1 - SI*YV2 RtQ(1,3) = CO*ZV1 - SI*ZV2 RtQ(2,1) = SI*XV1 + CO*XV2 RtQ(2,2) = SI*YV1 + CO*YV2 RtQ(2,3) = SI*ZV1 + CO*ZV2 RtQ(3,1) = XVEC RtQ(3,2) = YVEC RtQ(3,3) = ZVEC QRtQ(1,1) = XV1*RtQ(1,1) + XV2*RtQ(2,1) + XVEC*RtQ(3,1) QRtQ(1,2) = XV1*RtQ(1,2) + XV2*RtQ(2,2) + XVEC*RtQ(3,2) QRtQ(1,3) = XV1*RtQ(1,3) + XV2*RtQ(2,3) + XVEC*RtQ(3,3) QRtQ(2,1) = YV1*RtQ(1,1) + YV2*RtQ(2,1) + YVEC*RtQ(3,1) QRtQ(2,2) = YV1*RtQ(1,2) + YV2*RtQ(2,2) + YVEC*RtQ(3,2) QRtQ(2,3) = YV1*RtQ(1,3) + YV2*RtQ(2,3) + YVEC*RtQ(3,3) QRtQ(3,1) = ZV1*RtQ(1,1) + ZV2*RtQ(2,1) + ZVEC*RtQ(3,1) QRtQ(3,2) = ZV1*RtQ(1,2) + ZV2*RtQ(2,2) + ZVEC*RtQ(3,2) QRtQ(3,3) = ZV1*RtQ(1,3) + ZV2*RtQ(2,3) + ZVEC*RtQ(3,3) C mise a jour des valeurs des composantes du C nouveau mchaml necessitant la rotation C TRIGO1(I,IC)= 1 , 2 , 3 au max; C TRIGO1(I,IC)=-1 ou 0 pas de rotation SEGACT MCHEL1 DO 236 I=1,MCHEL1.ICHAML(/1) MCHAM3=MCHEL1.ICHAML(I) SEGACT MCHAM3 ICC1=0 NC=MCHAM3.NOMCHE(/2) DO 235 IC=1,NC C si les valeurs sont deja a jour : IF(TRIGO1(I,IC).LT.0) GO TO 235 C il y a TRIGO1(I,IC) ddl a traiter en meme temps: C incrementation de IC par les go to IF(IC.LT.ICC1) GO TO 235 ICC1=IC+TRIGO1(I,IC) * calcul plan, axi ou Fourier MELVA1=MCHAM3.IELVAL(IC) MELVA2=MCHAM3.IELVAL(IC+1) MELVA3=MCHAM3.IELVAL(IC+2) MELVA4=MCHAM3.IELVAL(IC+3) SEGACT, MELVA1*MOD,MELVA2*MOD,MELVA3*MOD,MELVA4*MOD * calcul 3D IF (TRIGO1(I,IC).EQ.6) THEN MELVA5=MCHAM3.IELVAL(IC+4) MELVA6=MCHAM3.IELVAL(IC+5) SEGACT, MELVA5*MOD,MELVA6*MOD ENDIF N1PTEL=MELVA1.VELCHE(/1) N1EL = MELVA1.VELCHE(/2) DO INPT = 1,N1PTEL DO IEL = 1,N1EL SIGM(1,1)=MELVA1.VELCHE(INPT,IEL) SIGM(2,2)=MELVA2.VELCHE(INPT,IEL) SIGM(1,2)=MELVA4.VELCHE(INPT,IEL) SIGM(2,1)=SIGM(1,2) SIGM(3,3)=MELVA3.VELCHE(INPT,IEL) IF (TRIGO1(I,IC).EQ.6) THEN SIGM(1,3)=MELVA5.VELCHE(INPT,IEL) SIGM(2,3)=MELVA6.VELCHE(INPT,IEL) SIGM(3,1)=SIGM(1,3) SIGM(3,2)=SIGM(2,3) ELSE SIGM(1,3)=0 SIGM(2,3)=0 SIGM(3,1)=0 SIGM(3,2)=0 ENDIF c nouvelles composantes = QRtQ SIGMA QtRtQ DO L=1,3 DO M=1,3 NSIG(L,M)=SIGM(L,1)*QRtQ(M,1)+SIGM(L,2)*QRtQ(M,2)+ & SIGM(L,3)*QRtQ(M,3) ENDDO ENDDO DO L=1,3 DO M=1,3 SIGM(L,M)=NSIG(1,M)*QRtQ(L,1)+NSIG(2,M)*QRtQ(L,2)+ & NSIG(3,M)*QRtQ(L,3) ENDDO ENDDO MELVA1.VELCHE(INPT,IEL)=SIGM(1,1) MELVA2.VELCHE(INPT,IEL)=SIGM(2,2) MELVA4.VELCHE(INPT,IEL)=SIGM(1,2) MELVA3.VELCHE(INPT,IEL)=SIGM(3,3) IF (TRIGO1(I,IC).EQ.6) THEN MELVA5.VELCHE(INPT,IEL)=SIGM(1,3) MELVA6.VELCHE(INPT,IEL)=SIGM(2,3) ENDIF ENDDO ENDDO 235 CONTINUE 236 CONTINUE SEGDES MSWBL1 * on arrete la le traitement. Par rapport a la programmation * du cas chpoint, il y a encore des verifs a faire sur l unicite * des composantes. Mais comme a ce jour, la definition du ET sur * les MCHAML n est pas claire, il faut reflechir ... 11/97 KICH. IP1 = MCHEL1 GOTO 994 992 CONTINUE SEGSUP MTRAV,ICPR 994 CONTINUE SEGSUP MSWBLO, MSWBL1 999 CONTINUE END