Sources Esope | Cast3M

kprjss
C KPRJSS    SOURCE    CB215821  20/11/25    13:32:50     10792          
      SUBROUTINE KPRJSS(MELEME,MELEM2,
     &IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IPAD,IK1,IKOMP)
 
      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,IZH2.IZHR
-INC SMMATRIK
-INC SMELEME
      POINTEUR MELEM2.MELEME
-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)//'PFP1'
       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.1)THEN
       IF(KPRE.EQ.5)NOM0=NOMS(ITYPEL)//'P1P1'
       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)
      IZH2=KZHR(2)
 
      SEGACT IZHR*MOD,IZH2*MOD
 
      NES=GR(/1)
      NPG=GR(/3)
      IZF1=KTP(1)
      SEGACT IZF1*MOD
      MP1=IZF1.FN(/1)
      MP=MELEM2.NUM(/1)
 
      DO 30 KE=1,NEL
 
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IKOMP = 1 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      IF(IKOMP.EQ.1)THEN
      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 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(K ))*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
 
 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
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IKOMP = 0 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      ELSE
      DO    I=1,NP
      J=NUM(I,KE)
      DO    N=1,IDIM
      IZH2.XYZ(N,I)=XCOOR((J-1)*(IDIM+1)    +N)
      ENDDO
      ENDDO
 
      CALL CALJBR(IZF1.FN,IZF1.GR,PG,
     & IZH2.XYZ,IZH2.HR,IZH2.PGSQ,IZH2.RPG,NES,IDIM,MP1,NPG,IAXI,AIRE,
     & IZH2.AJ,SGN)
 
C?    CALL CALJBR
C?   &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
C     write(6,*)' Retour caljbr ',mp1,np,npg
 
      DO 524 K=1,IDIM
      IPM4=KIPM(K)
      KG=(IK1-4)*(K-1)+1
 
      DO     M=1,MP1
 
      DO     I=1,NP
      U=0.D0
      DO 533 L=1,NPG
 
      CALL INITD(UA,3,0.D0)
      CALL INITD(UB,3,0.D0)
 
      DO 733 J=1,NP
      J1=LECT(NUM(J,KE))
      UA(KG)=UA(KG)+FN(J,L)*IZTGG1.VPOCHA(J1,KG)
      UB(K)=UB(K)+IZH2.HR(K,J,L)*IZTGG1.VPOCHA(J1,KG)
 733  CONTINUE
 
      U=U+IZF1.FN(M,L)*
     &(IZH2.HR(K,I,L)*UA(KG) + FN(I,L)*UB(K ))
     & *IZH2.PGSQ(L)*DEUPI*IZH2.RPG(L)
 
 533  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
 524  CONTINUE
 
      ENDIF
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 30   CONTINUE
 
      SEGSUP IZHR,IZFFM,IZH2
 
C CAS MACRO CENTRE
 
      ELSEIF(KPRE.EQ.2)THEN
        NOM0=NOMS(ITYPEL)//'    '
        CALL KALPBG(NOM0,'FONFORM ',IZFFM)
 
        SEGACT IZFFM*MOD
        IZHR=KZHR(1)
        IZH2=KZHR(2)
        SEGACT IZHR*MOD,IZH2*MOD
        NES=GR(/1)
        NPG=GR(/3)
        IZF1=KTP(1)
        SEGACT IZF1*MOD
        NPG=IZF1.FN(/2)
        MP1=IZF1.FN(/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     M=1,MP1
      DO     I=1,NP
      U=0.D0
      DO 433 L=1,NPG
 
      CALL INITD(UA,3,0.D0)
      CALL INITD(UB,3,0.D0)
      DO 833 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)
 833  CONTINUE
 
      U=U+IZF1.FN(M,L)*
     &(HR(K,I,L)*UA(KG) + FN(I,L)*UB(K ))*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
 
      ENDDO
      ENDDO
 424  CONTINUE
 
 40   CONTINUE
 
      SEGSUP IZHR,IZFFM,IZH2
 
      ENDIF
 
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4))
      END