Sources Esope | Cast3M

coq8gy
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