C KSPRJS    SOURCE    CB215821  20/11/25    13:33:11     10792          
      SUBROUTINE KSPRJS
     &(MELEME,IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IPAD,IK1)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*****************************************************************************
C
C     Ce SP calcule les matrices elementaires de divergence alias C
C
C  IKAS=1 KMCT calcul de Ct  (Div U)
C  IKAS=2 KMAC calcul de C uniquement  (Grad p)
C  IKAS=3 KCCT calcul de C assemblage pour C et Ct
C
C*****************************************************************************
      CHARACTER*8 NOM0


-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SIZFFB
      POINTEUR IZF1.IZFFM
-INC SMMATRIK
-INC SMELEME
-INC SMLENTI
-INC SMCHPOI
      POINTEUR IZTGG1.MPOVAL
-INC CCREEL
      DIMENSION KIPM(3),XYZ1(24),UA(3),UB(3)


C OPERATEUR PRESSION
C
      MLENTI=IPAD
      DEUPI=1.D0
      IF(IAXI.NE.0)DEUPI=2.D0*XPI
      IF(IKAS.EQ.3)DEUPI=-DEUPI

      IF(IDIM.EQ.2)IPM3=IPM1
      KIPM(1)=IPM1
      KIPM(2)=IPM2
      KIPM(3)=IPM3
      SEGACT MELEME,IPM1*MOD,IPM2*MOD,IPM3*MOD

      NP=NUM(/1)
      NEL=NUM(/2)

C      write(6,*)' INEFMD=',inefmd,'KPRE=',kpre
      IF(KPRE.NE.2)THEN
       IF(INEFMD.EQ.3)THEN
       IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'PRP0'
       IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'PRP1'
       IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'PRF1'
       ELSEIF(INEFMD.EQ.2)THEN
       IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'MCP0'
       IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'MCP1'
       IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'MCF1'
       ELSEIF(INEFMD.EQ.4)THEN
       NOM0=NOMS(ITYPEL)//'    '
       ENDIF
C      write(6,*)' NOM0=',nom0,' ikas=',ikas,' nel=',nel
       CALL KALPBG(NOM0,'FONFORM ',IZFFM)

      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NES=GR(/1)
      NPG=GR(/3)
      IZF1=KTP(1)
      SEGACT IZF1*MOD
      MP1=FN(/1)

      DO 30 KE=1,NEL

      DO    I=1,NP
      J=NUM(I,KE)
      DO    N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)    +N)
      ENDDO
      ENDDO

      CALL CALJBR
     &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
C     write(6,*)' Retour caljbr ',mp1,np,npg

      DO 324 K=1,IDIM
      IPM4=KIPM(K)
      KG=(IK1-4)*(K-1)+1

      DO     M=1,MP1

      DO     I=1,NP
      U=0.D0
      DO 333 L=1,NPG

      CALL INITD(UA,3,0.D0)
      CALL INITD(UB,3,0.D0)

      DO 533 J=1,NP
      J1=LECT(NUM(J,KE))
      UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG)
      UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG)
 533  CONTINUE

      U=U+FN(M,L)*
     &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L)
      IF(IAXI.NE.0.AND.K.EQ.1)THEN
      U=U+FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI
      ENDIF

 333  CONTINUE


      if(ikas.ne.2)then
      IPM4.AM(KE,I,M)=IPM4.AM(KE,I,M)+U
      else
      IPM4.AM(KE,M,I)=IPM4.AM(KE,M,I)+U
      endif

      ENDDO
      ENDDO
 324  CONTINUE

 37   CONTINUE
 30   CONTINUE

      SEGSUP IZHR,IZFFM


C CAS MACRO CENTRE

      ELSEIF(KPRE.EQ.2)THEN
        NOM0=NOMS(ITYPEL)//'    '
        CALL KALPBG(NOM0,'FONFORM ',IZFFM)

        SEGACT IZFFM*MOD
        IZHR=KZHR(1)
        SEGACT IZHR*MOD
        NES=GR(/1)
        NPG=GR(/3)
        IZF1=KTP(1)
        SEGACT IZF1*MOD
        MPG=IZF1.FN(/2)
c modif tc initialisation de M à 1 ??? (izf1.fn(/1))
        M=1

        NP=GR(/2)

        DO 40 KE=1,NEL

        IX=0
        DO    I=1,NP
        J=NUM(I,KE)
        DO    N=1,IDIM
        IX=IX+1
        XYZ1(IX)=XCOOR((J-1)*(IDIM+1)    +N)
        ENDDO
        ENDDO

      CALL CALJBR(FN,GR,PG,XYZ1,HR,PGSQ,RPG,NES,
     & IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)

      DO 424 K=1,IDIM
      IPM4=KIPM(K)
      KG=(IK1-4)*(K-1)+1

      DO 423 I=1,NP
      U=0.D0
      DO 433 L=1,NPG

      CALL INITD(UA,3,0.D0)
      CALL INITD(UB,3,0.D0)
      DO 633 J=1,NP
      J1=LECT(NUM(J,KE))
      UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG)
      UB(K)=UB(K)+HR(K,J,L)*IZTGG1.VPOCHA(J1,KG)
 633  CONTINUE

      U=U+IZF1.FN(M,L)*
     &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(KG))*PGSQ(L)*DEUPI*RPG(L)
      IF(IAXI.NE.0.AND.K.EQ.1)THEN
      U=U+IZF1.FN(M,L)*FN(I,L)*UA(KG)*PGSQ(L)*DEUPI
      ENDIF

 433  CONTINUE

      if(ikas.ne.2)then
      IPM4.AM(KE,I,1)=IPM4.AM(KE,I,1)+U
      else
      IPM4.AM(KE,1,I)=IPM4.AM(KE,1,I)+U
      endif

 423  CONTINUE
 424  CONTINUE

 40   CONTINUE

      SEGSUP IZHR,IZFFM

      ENDIF

      RETURN
 1002 FORMAT(10(1X,1PE11.4))
 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4))
      END