Sources Esope | Cast3M

kvol
C KVOL      SOURCE    CB215821  20/11/25    13:33:21     10792          
      SUBROUTINE KVOL(MELEME,MELEMC,TYPP,MCHPOI)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C
C     OBJET   : Cree un CHAMPOINT CENTRE contenant le volume des éléments
C               du domaine
C
C     SYNTAXE : CHPC = KVOL OBJDOM ;
C
C               OBJDOM : TABLE de SOUSTYPE DOMAINE
C
C*************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
      POINTEUR MELEMC.MELEME
-INC SMCOORD
-INC SMCHPOI
-INC SIZFFB
 
      REAL*8 AAJ(3,3,9),U,XC(3)
      PARAMETER (NTB=1)
      CHARACTER*8 LTAB(NTB),TYPE,TYPC
      CHARACTER*(*) TYPP
C***
      SEGACT MELEMC
      NC=1
      TYPE=TYPP
      CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
      CALL LICHTM(MCHPOI,MPOVAL,TYPC,IGEOM)
      SEGDES MELEMC
 
      SEGACT MELEME
 
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
 
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
 
      KK=0
      DO 1 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NP=IPT1.NUM(/1)
      NEL=IPT1.NUM(/2)
      TYPE=NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(TYPE,'FONFORM ',IZFFM)
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NES=GR(/1)
      NPG=GR(/3)
 
      DO 10 K=1,NEL
      KK=KK+1
      NPGR=0
      IF(IAXI.NE.0)NPGR=NPG
C
C     REMPLISSAGE DE XYZ
C     ------------------
C
      DO 12 I=1,NP
      J=IPT1.NUM(I,K)
      DO 12 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N)
 12   CONTINUE
 
      MP1=0
      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
 
C             CALCUL DU VOLUME / AIRE
 
      VPOCHA(KK,1)=AIRE
 
 10   CONTINUE
      SEGDES IPT1
 1    CONTINUE
      SEGDES MELEME,MPOVAL,MCHPOI
C
      RETURN
 
 90   CONTINUE
      WRITE(6,*)' Interruption anormale de KVOL'
      RETURN
 1001 FORMAT(20(1X,I5))
      END