Sources Esope | Cast3M

pb403
C PB403     SOURCE    MAGN      10/05/19    21:15:07     6676
      SUBROUTINE PB403(XREF,X,Y,Z,PG,FN,GR,FM,GM,ND,NP,MP,NPG,NOM2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C     CALCULE LES FONCTIONS DE FORME D'UN : TET4
C
C***********************************************************************
      CHARACTER*4 NOM2
      REAL*8 XREF(ND,NP),X(NPG),Y(NPG),Z(NPG)
      DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG)
      DIMENSION FM(MP,NPG),GM(ND,MP,NPG)
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      CO=6.D0 ** (1.D0/3.D0)
      UNSCO=1.D0/CO
      XXXX=-1.D0*UNSCO
C
      XREF(1,1)=0.D0
      XREF(2,1)=0.D0
      XREF(3,1)=0.D0
 
      XREF(1,2)=CO
      XREF(2,2)=0.D0
      XREF(3,2)=0.D0
 
      XREF(1,3)=0.D0
      XREF(2,3)=CO
      XREF(3,3)=0.D0
 
      XREF(1,4)=0.D0
      XREF(2,4)=0.D0
      XREF(3,4)=CO
C
 
C Verification des coordonnées
C     IF(.TRUE.)THEN
      IF(.FALSE.)THEN
      DO 11 L=1,NP
      X(L)=XREF(1,L)
      Y(L)=XREF(2,L)
      Z(L)=XREF(3,L)
 11   CONTINUE
 
      DO 12 L=1,NP
C
         FN(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
         FN(2,L)=X(L)*UNSCO
         FN(3,L)=Y(L)*UNSCO
         FN(4,L)=Z(L)*UNSCO
C
      write(6,1033)L,FN(1,L),FN(2,L),FN(3,L),FN(4,L)
 12   CONTINUE
 1033 FORMAT(1X,I4,' FN',10(1X,1PD11.4))
      ENDIF
C Fin Vérification
 
      IF(NPG.EQ.1)THEN
         XXXX=0.25D0*CO
C
         X(1)=XXXX
         Y(1)=XXXX
         Z(1)=XXXX
         PG(1)=1.D0
      ENDIF
      IF(NPG.EQ.4)THEN
         AL=.5854101966249684D0*CO
         BE=.1381966011250105D0*CO
C
         X(1)=BE
         Y(1)=BE
         Z(1)=BE
         PG(1)=0.25D0
C
         X(2)=AL
         Y(2)=BE
         Z(2)=BE
         PG(2)=0.25D0
C
         X(3)=BE
         Y(3)=AL
         Z(3)=BE
         PG(3)=0.25D0
C
         X(4)=BE
         Y(4)=BE
         Z(4)=AL
         PG(4)=0.25D0
C
      ENDIF
C
      DO 1 L=1,NPG
C
         FN(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
         FN(2,L)=X(L)*UNSCO
         FN(3,L)=Y(L)*UNSCO
         FN(4,L)=Z(L)*UNSCO
C
         GR(1,1,L)=XXXX
         GR(2,1,L)=XXXX
         GR(3,1,L)=XXXX
C
         GR(1,2,L)=UNSCO
         GR(2,2,L)=0.D0
         GR(3,2,L)=0.D0
C
         GR(1,3,L)=0.D0
         GR(2,3,L)=UNSCO
         GR(3,3,L)=0.D0
C
         GR(1,4,L)=0.D0
         GR(2,4,L)=0.D0
         GR(3,4,L)=UNSCO
C
 
      IF(NOM2.EQ.'P1P1')THEN
      FM(1,L)=FN(1,L)
      FM(2,L)=FN(2,L)
      FM(3,L)=FN(3,L)
      FM(4,L)=FN(4,L)
C
         GM(1,1,L)=XXXX
         GM(2,1,L)=XXXX
         GM(3,1,L)=XXXX
C
         GM(1,2,L)=UNSCO
         GM(2,2,L)=0.D0
         GM(3,2,L)=0.D0
C
         GM(1,3,L)=0.D0
         GM(2,3,L)=UNSCO
         GM(3,3,L)=0.D0
C
         GM(1,4,L)=0.D0
         GM(2,4,L)=0.D0
         GM(3,4,L)=UNSCO
C
      ELSE
      FM(1,L)=1.D0
      GM(1,1,L)=0.D0
      GM(2,1,L)=0.D0
      GM(3,1,L)=0.D0
      ENDIF
 
 1    CONTINUE
 
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C     WRITE(6,100)
C     WRITE(6,101)
C     WRITE(6,1002)FN
C     WRITE(6,1002)GR
C     WRITE(6,101)
      RETURN
 1002 FORMAT(10(1X,1PD11.4))
 1001 FORMAT(20(1X,I5))
 100  FORMAT(1H1)
 101  FORMAT(1X,'... SUB PB403 ... FN,GR,FOM,GM ',9(10H..........)/)
      END