Sources Esope | Cast3M

pf500
C PF500     SOURCE    CB215821  20/11/25    13:35:41     10792          
      SUBROUTINE PF500(IZDD,IPHI,IZSS,IZGG,IPHR,DT,MTABD,NUMCOM)
C************************************************************************
C
C Pointeurs :
C ---------
C    IZDD  : Diagonale
C    IPHI  : Resultat a l'instant precedent
C    IZSS  : densité de source
C    IZGG  : Champ point de type FACE representant les flux(l'increment)
C    IPHR  : Resultat
C    MTABD : table du maillage
C
C    MELEMA : Connectivites elements/faces 'ELTFA'
C    MCHELM : Sens des normales
C    MELEMF : Maillage de type face
C
C Variables :
C ---------
C    DT     : Pas de Temps
C    NUMCOM : Numero de Composante
C
C************************************************************************
C
C Objet : Fait le bilan par element pour un schema volume fini
C -----
C                   IPHR=IPHI + DT*(SOURCE) - DT*(FLUX)/DIAGONALE
C  ou encore        IPHR=IPHI + DT*IZSS - DT*IZGG/IZDD
C
C************************************************************************
C  Modifications pour prendre en compte les champs a plusieurs
C  composantes et rajout de Messages d'erreurs : P.G   Aout 96
C************************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
C
-INC SMTABLE
      POINTEUR MTABD.MTABLE
C
-INC SMELEME
      POINTEUR MELEMA.MELEME,MELEMC.MELEME,MELEMF.MELEME
C
-INC SMCHPOI
      POINTEUR IPHI.MPOVAL,IPHR.MPOVAL
      POINTEUR IZDD.MPOVAL,IZGG.MPOVAL,IZSS.MPOVAL
C
-INC SMCHAML
C
      REAL*8 PHI
C
C
C - Lecture du tableau des sens des normales : chamelem
C   ---------------------------------------------------
      CALL LEKTAB(MTABD,'XXNORMAE',MCHELM)
      IF(MCHELM.EQ.0)THEN
              MOTERR(1:40)='Pas de CHAMELEM des Normales            '
              CALL ERREUR(-301)
      GO TO 99
      ENDIF
      SEGACT MCHELM
C
C - Lecture des connexions Faces/Elements
C   -------------------------------------
      CALL LEKTAB(MTABD,'ELTFA',MELEMA)
      IF(MELEMA.EQ.0)THEN
              MOTERR(1:40)='Pas de Meleme connexions Faces/Elements '
              CALL ERREUR(-301)
      GO TO 99
      ENDIF
      SEGACT MELEMA
C
      CALL LEKTAB(MTABD,'FACE',MELEMF)
      IF(MELEMF.EQ.0)THEN
              MOTERR(1:40)='Pas de Meleme des FACES                 '
              CALL ERREUR(-301)
      GO TO 99
      ENDIF
      SEGACT MELEMF
C
C
      NBSOUS = MELEMA.LISOUS(/1)
C
      IF(NBSOUS.EQ.0)NBSOUS = 1
      II = 0
C
      NBF = MELEMF.NUM(/2)
      MELEMC = MELEMF
      CALL KRIPAD(MELEMC,MLENTI)
C     CALL RSETXI(LECT,MELEMF.NUM,NBF)
      SEGACT MELEMC
C
C - Boucle sur les sous Objets
C   ==========================
      DO 1 L=1,NBSOUS
      IPT1 = MELEMA
      IF(NBSOUS.NE.1)IPT1 = MELEMA.LISOUS(L)
      SEGACT IPT1
      NP = IPT1.NUM(/1)
      NEL = IPT1.NUM(/2)
      MCHAML = ICHAML(L)
      SEGACT MCHAML
      MELVAL = IELVAL(1)
      SEGACT MELVAL
C
C - Cas ou il n'y a pas de terme Source
C   -----------------------------------
C
      IF(IZSS.EQ.0)THEN
C
      DO 10 K=1,NEL
      II = II+1
      PHI = 0.D0
C
C                     bilan sur chaque element
C                     -----------------------
      DO 11 I=1,NP
         NF = IPT1.NUM(I,K)
         NF = LECT(NF)
         PHI = PHI + IZGG.VPOCHA(nf,numcom)*MELVAL.VELCHE(I,K)
 11   CONTINUE
C
      IPHR.VPOCHA(II,numcom) = IPHI.VPOCHA(II,numcom)
     &                   -DT*PHI/IZDD.VPOCHA(II,numcom)
C
 10   CONTINUE
C
      ELSE
C
C - Cas ou il n'y a un terme Source
C   -------------------------------
C
      DO 20 K=1,NEL
      II = II+1
      PHI = 0.D0
C
C                     bilan sur chaque element
C                     -----------------------
      DO 21 I=1,NP
         NF = IPT1.NUM(I,K)
         NF = LECT(NF)
         PHI = PHI + IZGG.VPOCHA(nf,numcom)*MELVAL.VELCHE(I,K)
 21   CONTINUE
C
      IPHR.VPOCHA(II,numcom)= IPHI.VPOCHA(II,numcom)
     1                 -DT*PHI/IZDD.VPOCHA(II,numcom)
     2                 +DT*IZSS.VPOCHA(II,numcom)
C
 20   CONTINUE
      ENDIF
      SEGDES IPT1,MELVAL,MCHAML
 1    CONTINUE
C
C - Fin de Boucle sur les Sous-Objets
C   =================================
C
      SEGSUP MLENTI
      SEGDES MELEMC,MELEMA,MELEMF,MCHELM
C
      RETURN
C
 99   CONTINUE
      MOTERR(1:40)='     Interruption anormale de PF500     '
      CALL ERREUR(-301)
C
      RETURN
      END