Sources Esope | Cast3M

flacoq
C FLACOQ    SOURCE    CHAT      05/01/13    00:02:57     5004
      SUBROUTINE FLACOQ(RE,XA,EP,CONT,XE,YE,ZE,P,XX,YY,BB,
     1 CC,RQP,RJ,SIG)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION CONT(*)
      DIMENSION RE(18,18),XA(3,3),SIG(3),JLIM(2,9),RJ(2,2),RP(9,9)
     1 ,RL(9,9)
      DIMENSION P(3,3),XX(3,3),YY(3,3),BB(3),CC(3),
     1 XE(3),YE(3),ZE(3)
      DIMENSION RQP(18,18)
      DATA JLIM/1,1,2,3,2,3,4,4,5,       6,5,6,7,7,8,9,8,9/
      DATA RL/ 0., 0., 0.,    0. ,0. ,0. ,   1. ,0. ,0. ,
     1         1., 0., 0.,    0. ,0. ,0. ,  -1. ,0. ,0. ,
     2         0., 0., 0.,    1. ,0. ,0. ,  -1. ,0. ,0. ,
     3    0., -0.5,0.5,0.,0.5,-0.5, 0., 0., 0.,
     4  0., 0., 0.,     0., 0.,   -0.5,   0.,   0.,   0.5,
     6 0.,-0.5,  0.,    0., 0., 0.,     0., 0.5, 0.,
     7 -1., 0.5, -0.5,      1.,  0.5,  -0.5,   0., 0., 0.,
     8 0., 0., 0.,    -1.,  0., 0.5,    1., 0., 0.5,
     9  1., -0.5,  0.,   0.,  0.,  0.,   -1.,   -0.5,  0./
      DATA RP/ 1., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     2         0., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     3         0., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     4         0., 0., 0.,   1., 0., 0.,    0., 0., 0.,
     5         0., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     6         0., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     7         0., 0., 0.,   0., 0., 0.,    1., 0., 0.,
     8         0., 0., 0.,   0., 0., 0.,    0., 0., 0.,
     9         0., 0., 0.,   0., 0., 0.,    0., 0., 0./
C    JUSQU A NOUVEL ORDRE LA PRESSION SERA NULLE PRENO=0.
      PRENO=0.
      DO 151 I=1,3
      XE(I)=XA(1,I)
      YE(I)=XA(2,I)
  151 ZE(I)=XA(3,I)
      CALL       PASSA(XE,YE,ZE,    P,X13,X23,Y13,Y23)
      RJ(1,1)=Y13
      RJ(2,1)=Y23
      RJ(1,2)= -X13
      RJ(2,2)=-X23
       DO 1 K=1,3
      IK=3*K-2
       DO 1 I=1,2
      II=IK+I
      DO 1 J=1,2
       IJ=IK+J
    1 RP(IJ,II)=RJ(J,I)
      DT=X13*Y23-Y13*X23
      SURF=DT
      SIG(1)=+CONT(1)
      SIG(2)=+CONT(2)
      SIG(3)=+CONT(3)
      DT=1./ABS(DT)
C ******  K  SIG  ET  K P  CALCULES AVEC  W LINEAIRES ********
C *****************
C    ****** BUNG    7  2  79  **************
       SURF=0.
      DO 12 I=1,18
      DO 12 J=1,18
   12 RQP(J,I)=0.
       BB(1)=Y23
       BB(2)=-Y13
       BB(3)=0.
        CC(1)=-X23
           CC(2)=X13
         CC(3)=X23-X13
          SIG(1)= SIG(1)*EP*0.50*DT
          SIG(2)= SIG(2)*EP*0.50*DT
          SIG(3)= SIG(3)*EP*0.50*DT
        DO 16  J=1,3
        JJ=(J-1)*6+1
        DO 17  I=1,3
       II=(I-1)*6+1
          S= SIG(1)*BB(I)*BB(J)+SIG(2)*CC(I)*CC(J)                   +
     1 SIG(3)*(BB(I)*CC(J)+BB(J)*CC(I))
      RQP(II,JJ)= RQP(II,JJ)+S
       RQP(II+1,JJ+1)=RQP(II+1,JJ+1)+S
       RQP(II+2,JJ+2)=RQP(II+2,JJ+2)+S
   17 CONTINUE
   16 CONTINUE
 
C    CALCUL DE KP  A PARTIR DES DEPLACEMENTS
        AUX=PRENO / 12.
       A1=AUX*(Y13+Y23)
       A2= AUX*(X13+X23)
       A3= AUX*(X13-2.*X23)
      A4 =AUX* (2.*X13-X23)
      A5=AUX*Y23
      A6= AUX*Y13
       RQP(1,9)=  A1
           RQP(9,1)=RQP(1,9)
       RQP(1,15)=  A5
           RQP(15,1)=RQP(1,15)
      RQP(2,9)=  -A2
           RQP(9,2)=RQP(2,9)
       RQP(2,15)=  A3
           RQP(15,2)=RQP(2,15)
       RQP(7,3)=  -A1
           RQP(3,7)=RQP(7,3)
       RQP(7,15)= -A6
            RQP(15,7)=RQP(7,15)
       RQP(8,3)=  A2
           RQP(3,8)=RQP(8,3)
       RQP(8,15)=     A4
              RQP(15,8)=   RQP(8,15)
       RQP(13,3)  =   -A5
           RQP(3,13) =RQP(13,3)
        RQP(13,9)=   A6
       RQP(9,13)   =   RQP(13,9 )
        RQP(14,3)=    -A3
               RQP(3,14)=   RQP(14,3)
        RQP(14,9)   =   -A4
              RQP(9,14)  = RQP(14,9)
      DO 6 K=1,6
      K1=3*(K-1)
      DO 6 L=K,6
      L1= 3*(L-1)
      DO 7 I=1,3
      IM=I+K1
       DO 7 J=1,3
      JM=J+L1
   7  XX(I,J)= RQP(IM,JM)
      CALL PRODT(YY,XX,P,3,3)
      DO 8 I=1,3
                        IM=I+K1
       DO 8 J=1,3
       JM=J+L1
   8   RE(IM,JM)=YY(I,J)
  6   CONTINUE
         DO   290  I=1,18
           DO 290    J=I,18
 290     RE(J,I)= RE( I,J)
      RETURN
      END