Sources Esope | Cast3M

kpriss
C KPRISS    SOURCE    PV        20/09/28    21:15:19     10727          
      SUBROUTINE KPRISS(MELEME,IPM1,IPM2,IPM3,IAXI,IKAS,MACRO,KPRE)
      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*****************************************************************************
      CHARACTER*8 NOM0
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SIZFFB
      POINTEUR IZF1.IZFFM
-INC SMMATRIK
-INC SMELEME
-INC CCREEL
      DIMENSION KIPM(3),XYZ1(24)
 
 
C OPERATEUR PRESSION
C
      DEUPI=1.D0
      IF(IAXI.NE.0)DEUPI=2.D0*XPI
 
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(MACRO.EQ.0)THEN
       IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'PRP0'
       IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'PRP1'
       ELSE
       IF(KPRE.EQ.3)NOM0=NOMS(ITYPEL)//'MCP0'
       IF(KPRE.EQ.4)NOM0=NOMS(ITYPEL)//'MCP1'
       ENDIF
       CALL KALPBG(NOM0,'FONFORM ',IZFFM)
C      write(6,*)' NOM0=',nom0,' ikas=',ikas,' nel=',nel
 
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NES=GR(/1)
      NPG=GR(/3)
      IZF1=KTP(1)
      SEGACT IZF1*MOD
      MP1=IZF1.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)
 
      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
 
      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)
        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)
 
      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
 
      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