Sources Esope | Cast3M

bgrcq2
C BGRCQ2    SOURCE    PV        11/04/07    21:15:00     6935
      SUBROUTINE BGRCQ2(BGR,DJAC,IGAU,IFOU,XEL,NN,T,P,IARR)
C|=================================================================|
C|           CALCUL DE LA MATRICE BGR DES COQUES @ 2 NOEUDS        |
C|               ROUTINE FORTRAN PUR                               |
C|      SUO X.Z. JANVIER 87                                        |
C|                                                                 |
C|= ENTREES                                                        |
C|    IGAU=NUMERO DU POINT DE GAUSS                                |
C|    IFOU=IFOUR DE CCOPTIO                                        |
C|    XEL=COORDONNEES LOCALE DE L'ELEMENT                          |
C|    NN=NUMERO DU MODE DE FOURIER                                 |
C|    T(IGAU)=POSITION DU POINT DE GAUSS                           |
C|    P(IGAU)=POIDS DU POINT DE GAUSS                              |
C|= SORTIE                                                         |
C|    BGR(9,8)=MATRICE BGR AU POINT DE GAUSSPOUR IFOU GT 0         |
C|    BGR(9,6)=MATRICE BGR AU POINT DE GAUSSPOUR IFOU LE 0         |
C|    DJAC=JACOBIEN AU POINT DE GAUSS=POIGAU*LONG/2 (*R(IGAU), SI  |
C|         IFOU EST SUPERIEUR OU EGAL A ZERO)                      |
C|    IARR=0 SI OK 1 SI LONGUEUR ELEMENT NULLE                     |
C|                 2 SI R / D INFERIEUR A 10-3                     |
C|                                                                 |
C|       CODE SUO X.Z.                                             |
C|=================================================================|
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER(XZER=0.D0,UNDE=.5D0,UN=1.D0,DEUX=2.D0,TRS=3.D0)
      PARAMETER(QUTR=4.D0,SIX=6.D0,DOUZ=12.D0)
      DIMENSION BGR(9,*),T(*),XEL(3,*),P(*)
C
C     ---------------------------------INITIALISATION
      IARR=0
      DJAC=XZER
          IF(IFOU.GT.0)  THEN
          CALL ZERO(BGR,9,8)
          ELSE IF(IFOU.LE.0) THEN
          CALL ZERO(BGR,9,6)
          ENDIF
C
      D=SQRT((XEL(1,2)-XEL(1,1))**2+(XEL(2,2)-XEL(2,1))**2)
      IF(D.EQ.0) THEN
        IARR=1
        GOTO 4
       ENDIF
      DD=UN/D
      RO=(XEL(1,1)+XEL(1,2))*UNDE
      SP=(XEL(1,2)-XEL(1,1))/D
      CP=(XEL(2,2)-XEL(2,1))/D
      SP2=SP*SP
      CP2=CP*CP
      SPCP=SP*CP
C           X FONCTION FORME NOEUD 2     RRRR RAYON
C           Y FONCTION FORME NOEUD 1     D LONGUEUR DD INVERSE LONGUEUR
      X=UNDE+UNDE*T(IGAU)
      Y=UNDE-UNDE*T(IGAU)
      RRRR=RO+UNDE*D*SP*T(IGAU)
C     ---------------------------------
C
C     TEST D'ERREUR
C
      IF(ABS(RRRR/D).LE.1.D-03.AND.IFOU.GE.0) THEN
        IARR=2
        GOTO 4
       ENDIF
C
C     =======   CALCULS  ======
C
      IF(IFOU.LT.0)   THEN
      RRRR=1.0D0
      ENDIF
      U=X/RRRR
      V=Y/RRRR
C
C          AXISYMMETRIQUE DEORMATIONS PLANES CONTRAINTES PLANES
C
      IF(IFOU.LE.0) THEN
C
C          GRADIAN DUDS
C
             BGR(1,1)=-SP*DD
             BGR(1,2)=-CP*DD
             BGR(1,4)=-BGR(1,1)
             BGR(1,5)=-BGR(1,2)
C
C            GRADIAN  DUDZ
C
           AUX = SIX*X*Y*DD
             BGR(3,1)=-CP*AUX
             BGR(3,2)= SP*AUX
             BGR(3,3)=-(UN-TRS*X)*Y
             BGR(3,4)= CP*AUX
             BGR(3,5)=-SP*AUX
             BGR(3,6)=-(TRS*X-DEUX)*X
C
C          GRADIAN  DVD0
C
             BGR(5,1)= V*(SP2+CP2*Y*(UN+DEUX*X))
             BGR(5,2)= SPCP*U*Y*T(IGAU)
             BGR(5,3)=-D*CP*X*Y*V
             BGR(5,4)= U*(SP2+CP2*X*(TRS-DEUX*X))
             BGR(5,5)=-SPCP*U*Y*T(IGAU)
             BGR(5,6)= D*CP*X*Y*U
C
C          GRADIAN  DWDS
C
            DO 999 I=1,6
            BGR(7,I) = -BGR(3,I)
  999       CONTINUE
C     ENDIF
C
C     =====  CALCUL EN SERIS DE FOURIER  =====
C
      ELSE IF(IFOU.GT.0) THEN
      AN=DBLE(NN)
C
C               GRADIAN DUDS
C
      BGR(1,1)=-SP*DD
      BGR(1,2)=-CP*DD
      BGR(1,5)=-BGR(1,1)
      BGR(1,6)=-BGR(1,2)
C
C               GRADIAN DVD0
C
      BGR(5,1)= V*(SP2+CP2*Y*(UN+DEUX*X))
      BGR(5,2)= SPCP*U*Y*T(IGAU)
      BGR(5,3)=-AN*V
      BGR(5,4)=-D*CP*X*Y*V
      BGR(5,5)= U*(SP2+CP2*X*(TRS-DEUX*X))
      BGR(5,6)=-SPCP*Y*U*T(IGAU)
      BGR(5,7)=-AN*U
      BGR(5,8)= D*CP*X*Y*U
C
C              GRADIAN  DUD0
C
      BGR(2,1)= -SP*V*AN
      BGR(2,2)= -CP*V*AN
      BGR(2,3)= V*SP
      BGR(2,5)= -SP*U*AN
      BGR(2,6)= -CP*U*AN
      BGR(2,7)= U*SP
C
C              GRADIAN  DVDS
C
      BGR(4,3)=DD
      BGR(4,7)=-DD
C
C           GRADIAN DUDZ
C
      AUX=SIX*Y*X*DD
      BGR(3,1)=-CP*AUX
      BGR(3,2)= SP*AUX
      BGR(3,4)=-(UN-TRS*X)*Y
      BGR(3,5)= CP*AUX
      BGR(3,6)=-SP*AUX
      BGR(3,8)=-(TRS*X-DEUX)*X
C
C          GRADIAN DVDZ
C
      AUX1=AN*Y*V*(UN+DEUX*X)
      AUX2=AN*X*U*(TRS-DEUX*X)
      BGR(6,1)=-CP*AUX1
      BGR(6,2)= SP*AUX1
      BGR(6,3)= V*CP
      BGR(6,4)= AN*D*X*Y*V
      BGR(6,5)=-CP*AUX2
      BGR(6,6)= SP*AUX2
      BGR(6,7)= U*CP
      BGR(6,8)=-AN*D*Y*X*U
C
C           GRADIAN  DWDS
C
            DO 10 I=1,8
            BGR(7,I)= -BGR(3,I)
   10  CONTINUE
C
C           GRADIAN DWD0
C
             DO 20 I=1,8
             BGR(8,I)= -BGR(6,I)
             BGR(9,I)=XZER
   20  CONTINUE
       DJAC=D*UNDE*P(IGAU)*RRRR
       ENDIF
    4  CONTINUE
      RETURN
      END