C COQ8GY SOURCE BP208322 11/09/14 21:15:01 7130 SUBROUTINE COQ8GY(NBNO,RHOK,NBPGAU,WRK1,MINTE,MINTE2,WRK7) C C |--------------------------------------------------------------| C | NOUVELLE PROCEDURE DE CALCUL DE LA MATRICE DE COUPLAGE | C | COUPLAGE GYROSCOPIQUE AVEC UN ELEMENT DE COQUE A 6/8 NOEUDS | C | | C | INSPIRE DU CALCUL DE LA MATRICE DE MASSE | C |--------------------------------------------------------------| C | ENTREES | C | NBPGAU : NOMBRE DE POINTS DE GAUSS. | C | MINTE : FONCTIONS DE FORME AUX POINTS DE GAUSS | C | MINTE2 : FONCTIONS DE FORME AUX NOEUDS | C | RHOK : MASSE VOLUMIQUE. | C | NBNO : NOMBRE DE NOEUDS | C | WRK7 : SEGMENT DE TRAVAIL (ACTIF) | C | Didier COMBESCURE mars 2003 | C |--------------------------------------------------------------| C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC SMINTE SEGMENT WRK7 REAL*8 XJI(3,3),TXR(3,3,NBNO),FINT(3,LRE),XJ(3,3),B(3,3) REAL*8 TH(NBNO),EXC(NBNO),H(NBNO) REAL*8 ROME(3,3),REWO(LRE,LRE) ENDSEGMENT SEGMENT WRK1 REAL*8 REL(LRE,LRE),XE(3,NBNO) ENDSEGMENT C C INITIALISATION DE LA MATRICE DE COUPLAGE C LRE=6*NBNO DO 10 J = 1,LRE DO 10 I = 1,LRE REL(I,J) = 0.D0 REWO(I,J) = 0.D0 10 CONTINUE * ESP = TH(1) EXCEN = EXC(1) * * CORRECTION RNUR LE 12 / 9 / 90 * CALL CQ8LOC(XE,NBNO,MINTE2.SHPTOT,TXR,IRR) * DO 80 LX = 1,NBPGAU E3 = DZEGAU(LX) WT = POIGAU (LX) DO 20 I=1,NBNO 20 H(I)=SHPTOT(1,I,LX) CALL CQ8JCE(LX,NBNO,E3,XE,TH,EXC,TXR,SHPTOT,B,DET,IRR) FACT = WT*DET*RHOK DO 30 J = 1, LRE FINT(1,J) = 0.D0 FINT(2,J) = 0.D0 FINT(3,J) = 0.D0 30 CONTINUE XJI(1,1) = 0.D0 XJI(2,2) = 0.D0 XJI(3,3) = 0.D0 DO 60 J = 1,NBNO XJI(1,2) = TXR(1,1,J)*TXR(2,2,J) - TXR(2,1,J)*TXR(1,2,J) XJI(1,3) = TXR(1,1,J)*TXR(3,2,J) - TXR(1,2,J)*TXR(3,1,J) XJI(2,1) = -XJI(1,2) XJI(2,3) = TXR(2,1,J)*TXR(3,2,J) - TXR(2,2,J)*TXR(3,1,J) XJI(3,1) = -XJI(1,3) XJI(3,2) = -XJI(2,3) J1 = (J-1)*6 + 1 J2 = J1 + 1 J3 = J2 + 1 J4 = J3 + 1 J5 = J4 + 1 J6 = J5 + 1 A1 = H(J)*(0.5*E3*ESP+EXCEN) FINT(1,J1) = H(J) FINT(1,J5) = A1*XJI(1,2) FINT(1,J6) = A1*XJI(1,3) FINT(2,J2) = FINT(1,J1) FINT(2,J4) = -FINT(1,J5) FINT(2,J6) = A1*XJI(2,3) FINT(3,J3) = FINT(1,J1) FINT(3,J4) = -FINT(1,J6) 60 FINT(3,J5) = -FINT(2,J6) DO 70 I = 1, LRE DO 70 J = I, LRE r_z = 0.D0 DO 71 K = 1,3 r_z = r_z + FINT(K,I)*FINT(K,J) 71 CONTINUE REWO(I,J) = REWO(I,J) + (FACT * r_z) c REWO(J,I) = REWO(I,J) c bp : on peut faire encore + efficace en executant cette ligne c apres la boucle 80 (cf boucle 77) 70 CONTINUE 80 CONTINUE DO 77 I = 1, LRE DO 77 J = I, LRE REWO(J,I) = REWO(I,J) 77 CONTINUE C DO 90 I = 1,NBNO DO 90 J = 1,NBNO DO 90 IN = 1,3 DO 90 IM = 1,3 REL((6*I)-6+IN,(6*J)-6+IM)=REWO((6*I)-6+IM,(6*J)-6+IM) . *ROME(IN,IM) REL((6*I)-3+IN,(6*J)-6+IM)=REWO((6*I)-3+IM,(6*J)-6+IM) . *ROME(IN,IM) REL((6*I)-6+IN,(6*J)-3+IM)=REWO((6*I)-6+IM,(6*J)-3+IM) . *ROME(IN,IM) REL((6*I)-3+IN,(6*J)-3+IM)=REWO((6*I)-3+IM,(6*J)-3+IM) . *ROME(IN,IM) C 90 CONTINUE C RETURN END