C PB603     SOURCE    MAGN      10/05/19    21:15:12     6676
      SUBROUTINE PB603(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
C
C************************************************************************

      REAL*8 XREF(ND,NP),X(NPG),Y(NPG),Z(NPG)
      CHARACTER*4 NOM2
      DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG)
      DIMENSION FM(MP,NPG),GM(ND,MP,NPG)
* TC n'a pas l'air de servir
*      DIMENSION U(5),H(5),XA(3),XB(3),XC(3),XD(3),XX(3)
**      SAVE XA,XB,XC,XD
*      DATA XA/3*0.25D0/,XB/0.75D0,0.25D0,0.75D0/
*      DATA XC/2*0.75D0,0.25D0/,XD/0.25D0,2*0.75D0/
C***
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      R2=SQRT(2.D0)
      NP2=NP*ND

      XREF(1,1)=0.D0
      XREF(2,1)=0.D0
      XREF(3,1)=0.D0
      XREF(1,2)=R2
      XREF(2,2)=0.D0
      XREF(3,2)=0.D0
      XREF(1,3)=0.D0
      XREF(2,3)=R2
      XREF(3,3)=0.D0

      XREF(1,4)=0.D0
      XREF(2,4)=0.D0
      XREF(3,4)=1.D0
      XREF(1,5)=R2
      XREF(2,5)=0.D0
      XREF(3,5)=1.D0
      XREF(1,6)=0.D0
      XREF(2,6)=R2
      XREF(3,6)=1.D0

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
      FN(1,L)=(X(L)+Y(L)-R2)*(Z(L)-1.D0)/R2
      FN(2,L)=-X(L)*(Z(L)-1.D0)/R2
      FN(3,L)=-Y(L)*(Z(L)-1.D0)/R2
      FN(4,L)=-(X(L)+Y(L)-R2)*Z(L)/R2
      FN(5,L)=X(L)*Z(L)/R2
      FN(6,L)=Y(L)*Z(L)/R2
      write(6,1033)L,FN(1,L),FN(2,L),FN(3,L),FN(4,L),FN(5,L),FN(6,L)
 12   CONTINUE
 1033 FORMAT(1X,I4,' FN',10(1X,1PD11.4))
      ENDIF
C Fin Vérification




      CALL CALHPR(X,Y,Z,PG,NPG)

      DO 1 L=1,NPG
C
      FN(1,L)=(X(L)+Y(L)-R2)*(Z(L)-1.D0)/R2
      FN(2,L)=-X(L)*(Z(L)-1.D0)/R2
      FN(3,L)=-Y(L)*(Z(L)-1.D0)/R2
      FN(4,L)=-(X(L)+Y(L)-R2)*Z(L)/R2
      FN(5,L)=X(L)*Z(L)/R2
      FN(6,L)=Y(L)*Z(L)/R2
C
      GR(1,1,L)=(Z(L)-1.D0)/R2
      GR(2,1,L)=(Z(L)-1.D0)/R2
      GR(3,1,L)=(X(L)+Y(L)-R2)/R2
      GR(1,2,L)=-(Z(L)-1.D0)/R2
      GR(2,2,L)=0.D0
      GR(3,2,L)=-X(L)/R2
      GR(1,3,L)=0.D0
      GR(2,3,L)=-(Z(L)-1.D0)/R2
      GR(3,3,L)=-Y(L)/R2
      GR(1,4,L)=-Z(L)/R2
      GR(2,4,L)=-Z(L)/R2
      GR(3,4,L)=-(X(L)+Y(L)-R2)/R2
      GR(1,5,L)=Z(L)/R2
      GR(2,5,L)=0.D0
      GR(3,5,L)=X(L)/R2
      GR(1,6,L)=0.D0
      GR(2,6,L)=Z(L)/R2
      GR(3,6,L)=Y(L)/R2
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)
      FM(5,L)=FN(5,L)
      FM(6,L)=FN(6,L)
C
      GM(1,1,L)=(Z(L)-1.D0)/R2
      GM(2,1,L)=(Z(L)-1.D0)/R2
      GM(3,1,L)=(X(L)+Y(L)-R2)/R2
      GM(1,2,L)=-(Z(L)-1.D0)/R2
      GM(2,2,L)=0.D0
      GM(3,2,L)=-X(L)/R2
      GM(1,3,L)=0.D0
      GM(2,3,L)=-(Z(L)-1.D0)/R2
      GM(3,3,L)=-Y(L)/R2
      GM(1,4,L)=-Z(L)/R2
      GM(2,4,L)=-Z(L)/R2
      GM(3,4,L)=-(X(L)+Y(L)-R2)/R2
      GM(1,5,L)=Z(L)/R2
      GM(2,5,L)=0.D0
      GM(3,5,L)=X(L)/R2
      GM(1,6,L)=0.D0
      GM(2,6,L)=Z(L)/R2
      GM(3,6,L)=Y(L)/R2
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     WRITE(6,101)

C     WRITE(6,1002)FM
C     WRITE(6,1002)GM
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))
 101  FORMAT(1X,'... SUBPB603 ... FM,GM,FN,GR ',9(10H..........)/)
C
      END