Sources Esope | Cast3M

kpruss
C KPRUSS    SOURCE    CB215821  20/11/25    13:32:53     10792          
      SUBROUTINE KPRUSS(MELEME,MELEM2,
     &IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IK1,K0,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 SMCHPOI
      POINTEUR IZTGG1.MPOVAL
-INC CCREEL
      DIMENSION KIPM(3),XYZ1(24)
 
 
C OPERATEUR PRESSION
C
      DEUPI=1.D0
      IF(IAXI.NE.0)DEUPI=2.D0*XPI
      IF(IKAS.EQ.3)DEUPI=-DEUPI
 
C     write(6,*)' 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)
 
      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,*)' Kpruss : 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
      NK=K0+KE
 
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)
 
      DO 324 K=1,IDIM
      IPM4=KIPM(K)
 
      DO     M=1,MP1
 
      DO     I=1,NP
      U=0.D0
      DO 333 L=1,NPG
      U=U+IZF1.FN(M,L)*HR(K,I,L)*PGSQ(L)*DEUPI*RPG(L)
 333  CONTINUE
 
      IF(IAXI.NE.0.AND.K.EQ.1)THEN
      DO 334 L=1,NPG
      U=U+IZF1.FN(M,L)*FN(I,L)*PGSQ(L)*DEUPI
 334  CONTINUE
      ENDIF
 
      K1=1+(1-IK1)*(NK-1)
      U=U*IZTGG1.VPOCHA(K1,1)
 
      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,MP1
      J=MELEM2.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)
 
      DO 524 K=1,IDIM
      IPM4=KIPM(K)
 
      DO     M=1,MP1
 
      DO     I=1,NP
      U=0.D0
      DO 533 L=1,NPG
      U=U+FN(I,L)*IZH2.HR(K,M,L)*IZH2.PGSQ(L)*DEUPI*IZH2.RPG(L)
 533  CONTINUE
 
      K1=1+(1-IK1)*(NK-1)
      U=U*IZTGG1.VPOCHA(K1,1)
 
      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%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 37   CONTINUE
 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
        MPG=IZF1.FN(/2)
        NP=GR(/2)
 
        DO 40 KE=1,NEL
 
        NK=K0+KE
 
        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)
 
      DO 423 I=1,NP
      U=0.D0
      DO 433 L=1,NPG
      U=U+HR(K,I,L)*PGSQ(L)*DEUPI*RPG(L)
 433  CONTINUE
 
      IF(IAXI.NE.0.AND.K.EQ.1)THEN
      DO 434 L=1,NPG
      U=U+FN(I,L)*PGSQ(L)*DEUPI
 434  CONTINUE
      ENDIF
 
      K1=1+(1-IK1)*(NK-1)
      U=U*IZTGG1.VPOCHA(K1,1)
 
      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,IZH2
 
      ENDIF
 
C     write(6,*)' Retour KPRUSS'
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
 1040 FORMAT(1X,'CALCUL MATRICE AM ',I4/10(1X,1PE11.4))
      END