1 : C COQ8GY SOURCE BP208322 11/09/14 21:15:01 7130 2 : SUBROUTINE COQ8GY(NBNO,RHOK,NBPGAU,WRK1,MINTE,MINTE2,WRK7) 3 : C 4 : C |--------------------------------------------------------------| 5 : C | NOUVELLE PROCEDURE DE CALCUL DE LA MATRICE DE COUPLAGE | 6 : C | COUPLAGE GYROSCOPIQUE AVEC UN ELEMENT DE COQUE A 6/8 NOEUDS | 7 : C | | 8 : C | INSPIRE DU CALCUL DE LA MATRICE DE MASSE | 9 : C |--------------------------------------------------------------| 10 : C | ENTREES | 11 : C | NBPGAU : NOMBRE DE POINTS DE GAUSS. | 12 : C | MINTE : FONCTIONS DE FORME AUX POINTS DE GAUSS | 13 : C | MINTE2 : FONCTIONS DE FORME AUX NOEUDS | 14 : C | RHOK : MASSE VOLUMIQUE. | 15 : C | NBNO : NOMBRE DE NOEUDS | 16 : C | WRK7 : SEGMENT DE TRAVAIL (ACTIF) | 17 : C | Didier COMBESCURE mars 2003 | 18 : C |--------------------------------------------------------------| 19 : C 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8 (A-H,O-Z) 22 : 23 : -INC SMINTE 24 : 25 : SEGMENT WRK7 26 : REAL*8 XJI(3,3),TXR(3,3,NBNO),FINT(3,LRE),XJ(3,3),B(3,3) 27 : REAL*8 TH(NBNO),EXC(NBNO),H(NBNO) 28 : REAL*8 ROME(3,3),REWO(LRE,LRE) 29 : ENDSEGMENT 30 : SEGMENT WRK1 31 : REAL*8 REL(LRE,LRE),XE(3,NBNO) 32 : ENDSEGMENT 33 : C 34 : C INITIALISATION DE LA MATRICE DE COUPLAGE 35 : C 36 : LRE=6*NBNO 37 : DO 10 J = 1,LRE 38 : DO 10 I = 1,LRE 39 : REL(I,J) = 0.D0 40 : REWO(I,J) = 0.D0 41 : 10 CONTINUE 42 : * 43 : ESP = TH(1) 44 : EXCEN = EXC(1) 45 : * 46 : * CORRECTION RNUR LE 12 / 9 / 90 47 : * 47 : CALL CQ8LOC(XE,NBNO,MINTE2.SHPTOT,TXR,IRR) 48 : * 49 : DO 80 LX = 1,NBPGAU 50 : E3 = DZEGAU(LX) 51 : WT = POIGAU (LX) 52 : DO 20 I=1,NBNO 53 : 20 H(I)=SHPTOT(1,I,LX) 53 : CALL CQ8JCE(LX,NBNO,E3,XE,TH,EXC,TXR,SHPTOT,B,DET,IRR) 54 : FACT = WT*DET*RHOK 55 : DO 30 J = 1, LRE 56 : FINT(1,J) = 0.D0 57 : FINT(2,J) = 0.D0 58 : FINT(3,J) = 0.D0 59 : 30 CONTINUE 60 : XJI(1,1) = 0.D0 61 : XJI(2,2) = 0.D0 62 : XJI(3,3) = 0.D0 63 : DO 60 J = 1,NBNO 64 : XJI(1,2) = TXR(1,1,J)*TXR(2,2,J) - TXR(2,1,J)*TXR(1,2,J) 65 : XJI(1,3) = TXR(1,1,J)*TXR(3,2,J) - TXR(1,2,J)*TXR(3,1,J) 66 : XJI(2,1) = -XJI(1,2) 67 : XJI(2,3) = TXR(2,1,J)*TXR(3,2,J) - TXR(2,2,J)*TXR(3,1,J) 68 : XJI(3,1) = -XJI(1,3) 69 : XJI(3,2) = -XJI(2,3) 70 : J1 = (J-1)*6 + 1 71 : J2 = J1 + 1 72 : J3 = J2 + 1 73 : J4 = J3 + 1 74 : J5 = J4 + 1 75 : J6 = J5 + 1 76 : A1 = H(J)*(0.5*E3*ESP+EXCEN) 77 : FINT(1,J1) = H(J) 78 : FINT(1,J5) = A1*XJI(1,2) 79 : FINT(1,J6) = A1*XJI(1,3) 80 : FINT(2,J2) = FINT(1,J1) 81 : FINT(2,J4) = -FINT(1,J5) 82 : FINT(2,J6) = A1*XJI(2,3) 83 : FINT(3,J3) = FINT(1,J1) 84 : FINT(3,J4) = -FINT(1,J6) 85 : 60 FINT(3,J5) = -FINT(2,J6) 86 : DO 70 I = 1, LRE 87 : DO 70 J = I, LRE 88 : r_z = 0.D0 89 : DO 71 K = 1,3 90 : r_z = r_z + FINT(K,I)*FINT(K,J) 91 : 71 CONTINUE 92 : REWO(I,J) = REWO(I,J) + (FACT * r_z) 93 : c REWO(J,I) = REWO(I,J) 94 : c bp : on peut faire encore + efficace en executant cette ligne 95 : c apres la boucle 80 (cf boucle 77) 96 : 70 CONTINUE 97 : 80 CONTINUE 98 : DO 77 I = 1, LRE 99 : DO 77 J = I, LRE 100 : REWO(J,I) = REWO(I,J) 101 : 77 CONTINUE 102 : C 103 : DO 90 I = 1,NBNO 104 : DO 90 J = 1,NBNO 105 : DO 90 IN = 1,3 106 : DO 90 IM = 1,3 107 : REL((6*I)-6+IN,(6*J)-6+IM)=REWO((6*I)-6+IM,(6*J)-6+IM) 108 : . *ROME(IN,IM) 109 : REL((6*I)-3+IN,(6*J)-6+IM)=REWO((6*I)-3+IM,(6*J)-6+IM) 110 : . *ROME(IN,IM) 111 : REL((6*I)-6+IN,(6*J)-3+IM)=REWO((6*I)-6+IM,(6*J)-3+IM) 112 : . *ROME(IN,IM) 113 : REL((6*I)-3+IN,(6*J)-3+IM)=REWO((6*I)-3+IM,(6*J)-3+IM) 114 : . *ROME(IN,IM) 115 : C 116 : 90 CONTINUE 117 : C 118 : RETURN 119 : END 120 : 121 : 122 :
© Cast3M 2003 - All rights reserved.
Disclaimer