Sources Esope | Cast3M

prgfm1
C PRGFM1    SOURCE    OF166741  24/12/13    21:17:09     12097          
      SUBROUTINE PRGFM1(NESP,
     &     IM1,IPHI,ICH1,ICH2,ICH3,ICH4,ICH5,
     &     MLRMGA,MLRPGA,MLRMPI,MLRPPI,
     &     IVIT,IPRES,IY,
     &     LOGNEG,MESERR,
     &     VALER)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRGFM1
C
C DESCRIPTION       :  VOIR PRIGFM
C
C                      Gaz ideal mono-espece:
C                      Calcul de vitesse, pression.
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/TTMF
C
C************************************************************************
C
C APPELES (E/S)     :  LICHT
C
C************************************************************************
C
C ENTREES  :
C
C            NESP    : nombre d'especes dans les equation d'Euler.
C
C            IM1     : MELEME contenant les centres des ELTs
C
C            IPHI    : CHPOINT  contenant PHI
C
C            ICH1    : CHPOINT  contenant la masse volumique.
C
C            ICH2    : CHPOINT contenant les dèbits
C                     ( NDIM  composantes);
C
C            ICH3    : CHPOINT  contenat l'énergie totale per
C                      unité de volume (RHO Et);
C
C            ICH4, ICH5 : CHPOINT  contenants rhoy et alpha ;
C
C            MLRMGA,MLRPGA,MLRMPI,MLRPPI: proprietés des gaz 1
C
C SORTIES  :
C
C            IY      : CHPOINT contenany y
C
C            IVIT    : CHPOINT  contenant la vitesse
C
C            IPRES   : CHPOINT  contenant la pression du gaz;
C
C            LOGNEG  : (LOGICAL): si .TRUE. une pression ou une densité
C                      negative a été detectée -> le programme s'arrete
C                      (sa valeur stockée en MESERR(1) et VALER(1))
C
C            MESERR,
C            VALER   : pour message d'erreur
C
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE :  Créée le 1.11.2010
C
C************************************************************************
C
C**** Les variables
C
      IMPLICIT INTEGER(I-N)
      INTEGER NESP, IESP,
     &        IM1,ICH1,ICH2,ICH3,ICH4,ICH5
     &       ,IVIT,IPRES,IPHI, IY
     &       ,NLCE, N1, IGEOMC
      REAL*8  VALER(2)
     &        ,RO,UX,UY,UZ,P
     &        ,ROET, ROETH, CELL, PHI
     &        ,GAMMA,PINF
     &        ,ALP, RNUM, DEN, ALPI
C
      CHARACTER*(8) TYPE
      CHARACTER*(40) MESERR(2)
      LOGICAL LOGNEG
C
C
C**** Les includes
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
      POINTEUR MPOVA7.MPOVAL, MPOVRY.MPOVAL,
     &     MPOVAY.MPOVAL, MPOALP.MPOVAL
-INC SMELEME
-INC SMLREEL
      POINTEUR MLRMGA.MLREEL, MLRPGA.MLREEL,
     &     MLRMPI.MLREEL, MLRPPI.MLREEL
C
C
C**** Initialisation des variables pour la gestion des erreurs pas ici,
C     mais avant, i.e.
C
C      LOGNEG  = .FALSE.
C      MESERR(1)  = '                                        '
C      MESERR(2)  = '                                        '
C
C**** Activation du MELEME "CENTRE"
C
      IPT1 = IM1
      SEGACT IPT1
      N1 = IPT1.NUM(/2)
      SEGDES IPT1
C
C**** Creation des CHPOINTs IVIT, IPRES
C
C     ITEMP CHPOINT simile aux ICH1
C     Donc on lit ICH1
C
      MCHPO1 = ICH1
      SEGACT MCHPO1
      MSOUP1 = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUP1
      MPOVA1 = MSOUP1.IPOVAL
      SEGDES MSOUP1
      SEGACT MPOVA1
C
C***  MPOVA6 = IPOVAL de IPRES
C
      SEGINI, MPOVA6 = MPOVA1
      SEGINI, MSOUP2 = MSOUP1
      MSOUP2.IPOVAL = MPOVA6
      SEGINI, MCHPO2 = MCHPO1
      MCHPO2.IPCHP(1)= MSOUP2
      SEGDES MSOUP2
      SEGDES MCHPO2
      IPRES = MCHPO2
C
C***  IVIT simil au CHPOINT ICH2 (DEBITs).
C
      MCHPO1 = ICH2
      SEGACT MCHPO1
      MSOUP1 = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUP1
      MPOVA2 = MSOUP1.IPOVAL
      SEGDES MSOUP1
      SEGACT MPOVA2
C
C**** IVIT
C
      SEGINI, MPOVA5 = MPOVA2
      SEGINI, MSOUP2 = MSOUP1
      MSOUP2.IPOVAL = MPOVA5
      SEGINI, MCHPO2 = MCHPO1
      MCHPO2.IPCHP(1)= MSOUP2
      SEGDES MSOUP2
      SEGDES MCHPO2
      IVIT = MCHPO2
C
      IF (NESP .GE. 1) THEN
C
C***  IY
C
C     Ce CHPOINT ressemble à IROY
C     Donc on lit IROY
C
         MCHPO1 = ICH4
         SEGACT MCHPO1
         MSOUP1 = MCHPO1.IPCHP(1)
         SEGDES MCHPO1
         SEGACT MSOUP1
         MPOVRY = MSOUP1.IPOVAL
         SEGDES MSOUP1
         SEGACT MPOVRY
C
         SEGINI, MPOVAY = MPOVRY
         SEGINI, MSOUP2 = MSOUP1
         MSOUP2.IPOVAL = MPOVAY
         SEGINI, MCHPO2 = MCHPO1
         MCHPO2.IPCHP(1)= MSOUP2
         SEGDES MSOUP2
         SEGDES MCHPO2
         IY = MCHPO2
C
         CALL LICHT(ICH5,MPOALP,TYPE,IGEOMC)
C        SEGACT MPOALP
      ELSE
         IY=0
      ENDIF
C
C**** Lecture de MPOVALs  des autres MCHPOIs
C
      CALL LICHT(ICH3,MPOVA3,TYPE,IGEOMC)
      CALL LICHT(IPHI,MPOVA7,TYPE,IGEOMC)
C
C**** LICHT active les MPOVALs en *MOD
C
C     i.e.
C
C     SEGACT MPOVA3*MOD
C     SEGACT MPOVA7*MOD
C
C
C**** RICAPITOLATIF
C
C     On a activé que les MPOVA1 - MPOVA7
C
C     MPOVA1 = RO
C     MPOVA2 = DEBIT
C     MPOVA3 = ROET
C     MPOVA5 = VITESSE
C     MPOVA6 = PRES
C     MPOVA7 = IPHI
C     MPOVRY = RHO Y
C     MPOVAY = Y
C     MPOALP = ALPHA
C
C**** BOUCLE SUR LES CENTRES pour le calcul du FLUX.
C
      DO NLCE = 1, N1
C
C******* Les differents variables a chaque centre
C
         RO   = MPOVA1.VPOCHA(NLCE,1)
         IF(RO .LE. 0.0D0)THEN
            VALER(1) = RO
            MESERR(1) = 'RO                                      '
            LOGNEG = .TRUE.
C
C********** RO &lt; 0: le programme s'arrete mais apres le calcul des
C                   CHPOINTs
C
         ENDIF
         UX = MPOVA2.VPOCHA(NLCE,1)/RO
         UY = MPOVA2.VPOCHA(NLCE,2)/RO
         MPOVA5.VPOCHA(NLCE,1)=UX
         MPOVA5.VPOCHA(NLCE,2)=UY
         IF(IDIM .EQ. 3) THEN
            UZ = MPOVA2.VPOCHA(NLCE,3)/RO
            MPOVA5.VPOCHA(NLCE,3)=UZ
         ENDIF
         ROET = MPOVA3.VPOCHA(NLCE,1)
         PHI = MPOVA7.VPOCHA(NLCE,1)
         CELL = UX*UX + UY*UY
         IF(IDIM .EQ. 3) CELL = CELL +UZ*UZ
         CELL = 0.5D0 * CELL *RO
         ROETH = ROET - CELL
C
C******* We compute GAMMA and PINF
C
         ALP = 1.0D0
         DEN = 0.0D0
         RNUM = 0.0D0
         DO IESP = 1, NESP, 1
            IF (PHI .LE. 0)THEN
               GAMMA = MLRMGA.PROG(IESP)
               PINF =  MLRMPI.PROG(IESP)
            ELSE
               GAMMA = MLRPGA.PROG(IESP)
               PINF =  MLRPPI.PROG(IESP)
            ENDIF
            ALPI = MPOALP.VPOCHA(NLCE,IESP)
            ALP = ALP - ALPI
            DEN = DEN + (ALPI / (GAMMA - 1.0D0))
            RNUM = RNUM  + ((ALPI * GAMMA * PINF) / (GAMMA - 1.0D0))
         ENDDO
         IF (PHI .LE. 0)THEN
            GAMMA = MLRMGA.PROG(NESP + 1)
            PINF =  MLRMPI.PROG(NESP + 1)
         ELSE
            GAMMA = MLRPGA.PROG(NESP + 1)
            PINF =  MLRPPI.PROG(NESP + 1)
         ENDIF
         DEN = DEN + (ALP / (GAMMA - 1.0D0))
         RNUM = RNUM  + ((ALP * GAMMA * PINF) / (GAMMA - 1.0D0))
C
         PINF = RNUM / DEN
         GAMMA = 1.0D0 / DEN
         GAMMA = GAMMA + 1.0D0
         PINF = PINF / GAMMA
C
C         write(*,*)
C         write(*,*) 'gamma, pinf ', gamma, pinf
         P = (GAMMA - 1.0D0) * ROETH
         P = P - (GAMMA * PINF)
         IF(P .LE. (-1.0D0 * PINF)) THEN
            VALER(1) = P
            MESERR(1) = 'P                                       '
            LOGNEG = .TRUE.
C
C********** P &lt; 0: le programme s'arrete mais apres le calcul des
C                   CHPOINTs
C
         ENDIF
         MPOVA6.VPOCHA(NLCE,1) = P
C
         DO IESP = 1, NESP
            MPOVAY.VPOCHA(NLCE,IESP) = MPOVRY.VPOCHA(NLCE,IESP) / RO
         ENDDO
      ENDDO
C
      SEGDES MPOVA1
      SEGDES MPOVA2
      SEGDES MPOVA3
      SEGDES MPOVA5
      SEGDES MPOVA6
      SEGDES MPOVA7
      IF (NESP .GE. 1) THEN
         SEGDES MPOVRY
         SEGDES MPOALP
         SEGDES MPOVAY
      ENDIF
C
      RETURN
      END