C BB403     SOURCE    CHAT      05/01/12    21:35:58     5004
      SUBROUTINE BB403(X,Y,Z,PG,FN,GR,FM,GM,ND,NP,MP,NPG)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C     CALCULE LES FONCTIONS DE FORME D'UN : TET5 (TET4 + Bulle)
C
C***********************************************************************
      REAL*8 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)
      ALFA=(4.D0/CO)**4.D0
C
      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
      UNSCO=1.D0/CO
      XXXX=-CO
      DO 1 L=1,NPG
      BB=(CO-X(L)-Y(L)-Z(L))*X(L)*Y(L)*Z(L)*ALFA
      BX=ALFA*(Y(L)*Z(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
      BY=ALFA*(X(L)*Z(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
      BZ=ALFA*(X(L)*Y(L)*(CO-X(L)-Y(L)-Z(L))-(X(L)*Y(L)*Z(L)))
C
         FM(1,L)=1.D0-(X(L)+Y(L)+Z(L))*UNSCO
         FM(2,L)=X(L)*UNSCO
         FM(3,L)=Y(L)*UNSCO
         FM(4,L)=Z(L)*UNSCO
C
         FN(1,L)=FM(1,L)*(1.D0-BB)
         FN(2,L)=FM(2,L)*(1.D0-BB)
         FN(3,L)=FM(3,L)*(1.D0-BB)
         FN(4,L)=FM(4,L)*(1.D0-BB)
         FN(5,L)=BB
C
         GR(1,1,L)=-UNSCO*(1.D0-BB)-BX*FM(1,L)
         GR(2,1,L)=-UNSCO*(1.D0-BB)-BY*FM(1,L)
         GR(3,1,L)=-UNSCO*(1.D0-BB)-BZ*FM(1,L)
C
         GR(1,2,L)=UNSCO*(1.D0-BB)-BX*FM(2,L)
         GR(2,2,L)=-BY*FM(2,L)
         GR(3,2,L)=-BZ*FM(2,L)
C
         GR(1,3,L)=-BX*FM(3,L)
         GR(2,3,L)=UNSCO*(1.D0-BB)-BY*FM(3,L)
         GR(3,3,L)=-BZ*FM(3,L)
C
         GR(1,4,L)=-BX*FM(4,L)
         GR(2,4,L)=-BY*FM(4,L)
         GR(3,4,L)=UNSCO*(1.D0-BB)-BZ*FM(4,L)
C
         GR(1,5,L)=BX
         GR(2,5,L)=BY
         GR(3,5,L)=BZ
C
         GM(1,1,L)=-UNSCO
         GM(2,1,L)=-UNSCO
         GM(3,1,L)=-UNSCO
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

 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