C PRIGFM    SOURCE    BECC      11/05/18    21:15:35     6973           
      SUBROUTINE PRIGFM()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRIGFM (OPERATEUR GIBIANE)
C
C DESCRIPTION       :  Voir PRIMIT
C                            
C                      GFMP. Calcul des variables primitives. 
C    
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C      
C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/TTMF                        
C
C************************************************************************
C
C
C APPELES (E/S)     : LIROBJ, QUEPOI, QUEPO1, ERREUR, ECROBJ, LIRCHA, 
C                     ECRCHA
C     
C APPELES (Calcul)  : PRGFM1
C
C
C************************************************************************
C
C PHRASE D'APPEL (GIBIANE) :
C
C RCHPO0 [=vn] RCHPO1[=pn] (RCHPO2 [=yn])  = 'PRIM' 'GFMP' TAB1  
C                           CHPO0 [=phi] CHPO1 [=rn] CHPO2 [=gn] 
C                           CHPO3 [=ren] (CHPO4 [=ryn]) (CHPO5 [=aln]) ;
C
C ENTREES  : 
C
C    TAB1 : TABLE qui contient :
C          * les noms des espèces qui apparaissent explicitement
C            dans les équations d'Euler en TAB1 . 'ESPEULE' 
C            (LISTMOTS) ;
C          * le nom de l'espèce qui n'y est pas 
C            (TAB1 . 'ESPNEULE' (MOT)) ;
C          * les gamma et leS pinf dans la zone phi < 0
C            TAB1 . 'MGAM' (LISTREEL) ;
C            TAB1 . 'MPIN' (LISTREEL) ;
C          * les gamma et les pinf dans la zone phi > 0
C            TAB1 . 'PGAM' (LISTREEL) ;
C            TAB1 . 'PPIN' (LISTREEL) ;
C            NB 
C            La première valeur dans les objets LISTEEL
C            TAB1 . 'MGAM', ... est celle de l'espèce
C            TAB1 . 'ESPNEULE'; les autres sont celles des
C            espèces TAB1 . 'ESPEULE'.
C                    
C            CHPO0   : CHPOINT  contenant la fonction phi
C                      (une composante, 'SCAL').
C
C            CHPO1   : CHPOINT  contenant la masse volumique
C                      (une composante, 'SCAL').
C
C            CHPO2   : CHPOINT  contenant les débits
C                     (2 composantes en 2D, 'UX  ','UY  ');
C     
C            CHPO3   : CHPOINT  contenant l'énergie totale per
C                      unité de volume (RHO Et),
C                      (une composante, 'SCAL').
C
C            CHPO4   : CHPOINT  contenant les masses volumiques
C                      des espèces en (TAB1. 'ESPEULE')
C                      (composante dans TAB1. 'ESPEULE').
C
C            CHPO5   : CHPOINT  contenant les fractions volumiques
C                      des espèces en (TAB1. 'ESPEULE')
C                      (composante dans TAB1. 'ESPEULE').
C
C
C            MCLE2   : Option personnelle: pas dans la notice
C                      officielle!!! 
C                      Mot clé, 'TRICHE' (s'il y a un erreur,
C                      les objets RCHPO1 et RCHPO2 ne sont pas
C                      des type ANNULE et le programme
C                      ne s'arrête pas!!!)
C 
C SORTIES  : 
C
C            RCHPO0  : CHPOINT  contenant la vitesse
C
C            RCHPO1  : CHPOINT  contenant la pression du gaz;
C      
C            RCHPO2  : CHPOINT  contenant les fractions massiques
C                      des espèces en (TAB1. 'ESPEULE')
C                      (composante dans TAB1. 'ESPEULE').
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
C     &        ,MCOORD      
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
C
C**** Les variables
C
      IMPLICIT INTEGER(I-N)
      INTEGER NESP, NESP1
      INTEGER ICOND, IRETOU, INDIC, NBCOMP
     &       , ICEN, IRO, IROVIT, IROET
     &       , IPRES, IVIT, JGN, JGM, IPHI
     &       , IPGAS, IROY, IALP, IY
      REAL*8 VALER(2)
      CHARACTER*(40) MESERR(2),MESCEL
      CHARACTER*(4)  MOT(1)
      CHARACTER*(6) NOMTRI
      CHARACTER*(8) MTYPR, MTYPI
      LOGICAL LOGNEG, LOGTRI
C
C**** Variables en ACCTAB
C
      INTEGER IVALI, IRETI,IVALR, IRETR
      REAL*8 XVALI,XVALR
      LOGICAL LOGII, LOGIR
      CHARACTER*(8) CHARR
C     
C**** Les Includes
C
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
-INC SMLREEL
      POINTEUR MLRMGA.MLREEL, MLRPGA.MLREEL, 
     &     MLRMPI.MLREEL, MLRPPI.MLREEL
C
C
C**** Initialisation des parametres d'erreur
C
      LOGNEG  = .FALSE.
      MESCEL = '                                        '
      MESERR(1) = MESCEL
      MESERR(2) = MESCEL
      MOTERR(1:40) = MESCEL
      VALER(1) = 0.0D0
      VALER(2) = 0.0D0
C
C**** Initialisation des MOT(1)
C
      MOT(1) = '    '
C
C**** Initialisation des variables en ACCTAB
C
      IVALI = 0
      IVALR = 0
      XVALI = 0.0D0
      XVALR = 0.0D0
      LOGII = .FALSE.
      LOGIR = .FALSE.
      IRETI = 0
      IRETR = 0
      CHARR = '        '
C
C**************************************************      
C**** Lecture de la table des proprietes du gaz ***
C**************************************************
C
      ICOND = 1
      CALL QUETYP(MTYPR,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(MTYPR .NE. 'TABLE   ')THEN
C
C******* Message d'erreur standard
C        37 2
C        On ne trouve pas d'objet de type %m1:8
C     
         MOTERR(1:8) = 'TABLE   ' 
         CALL ERREUR(37)
         GOTO 9999
      ELSE
         ICOND = 1
         CALL LIROBJ(MTYPR,IPGAS,ICOND,IRETOU)
         IF(IERR .NE. 0)GOTO 9999
      ENDIF         
C
C**** Nom de l'espece qui n'est pas dans les equations d'Euler
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,'ESPNEULE', LOGII,IRETI,
     &                  MTYPR,IVALR,XVALR ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'MOT     ')) THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR = 'TAB1 . ESPNEULE = ???        '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C**** Les especes qui sont dans les Equations d'Euler
C
      MTYPR = '        ' 
      CALL ACMO(IPGAS,'ESPEULE',MTYPR,MLMOT1)
      IF(MTYPR .NE. 'LISTMOTS')THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'TAB1 . ESPEULE = ???                    '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
      SEGACT MLMOT1
      NESP = MLMOT1.MOTS(/2)
      SEGDES MLMOT1
C
C     JGN = 4
C     JGM =  NESP + 1
C     SEGINI MLMOT2
C     DO I1 = 1, NESP, 1
C        MLMOT2.MOTS(I1) = MLMOT1.MOTS(I1)
C     ENDDO
C     MLMOT2.MOTS(NESP+1)=CHARR(1:4)
C      DO I1 = 1, (NESP + 1)
C         write(*,*) MLMOT2.MOTS(I1)
C      ENDDO
C     SEGSUP MLMOT2
C      stop
C
C
C**** List de gamma, PHI < 0 (MLRMGA, MLRrel Minus GAMMA)
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,'MGAM', LOGII,IRETI,
     &                  MTYPR,IVALR,XVALR ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'LISTREEL')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = ' TAB1 . MGAM = ???                      '
         WRITE(IOIMP,*) MOTERR
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
      MLRMGA = IRETR
      SEGACT MLRMGA
      NESP1 = MLRMGA.PROG(/1)
      IF(NESP1 .NE. (NESP + 1))THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = 'DIME(TAB1.MGAM)    != NESP              '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
C
C**** List de gamma, PHI > 0 (MLRPGA, MLRrel Plus GAMMA)
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,'PGAM', LOGII,IRETI,
     &                  MTYPR,IVALR,XVALR ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'LISTREEL')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = ' TAB1 . PGAM = ???                      '
         WRITE(IOIMP,*) MOTERR
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
      MLRPGA = IRETR
      SEGACT MLRPGA
      NESP1 = MLRPGA.PROG(/1)
      IF(NESP1 .NE. (NESP + 1))THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = 'DIME(TAB1.PGAM)    != NESP              '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
C
C**** List de PINF, PHI < 0 (MLRMPI)
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,'MPIN', LOGII,IRETI,
     &                  MTYPR,IVALR,XVALR ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'LISTREEL')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = ' TAB1 . MPIN = ???                      '
         WRITE(IOIMP,*) MOTERR
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
      MLRMPI = IRETR
      SEGACT MLRMPI
      NESP1 = MLRMPI.PROG(/1)
      IF(NESP1 .NE. (NESP + 1))THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = 'DIME(TAB1.MPIN)    != NESP              '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
C
C**** List de PINF, PHI > 0 (MLRPPI)
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,'PPIN', LOGII,IRETI,
     &                  MTYPR,IVALR,XVALR ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'LISTREEL')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = ' TAB1 . PPIN = ???                      '
         WRITE(IOIMP,*) MOTERR
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
      MLRPPI = IRETR
      SEGACT MLRPPI
      NESP1 = MLRPPI.PROG(/1)
      IF(NESP1 .NE. (NESP + 1))THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = 'DIME(TAB1.PPIN)    != NESP              '
         WRITE(IOIMP,*) MOTERR(1:40)
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF  
C
C***********************************************************************
C******************** Lecture du reste *********************************
C***********************************************************************
C      
C**** Lecture du CHPOINT ROPHI
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',IPHI,ICOND,IRETOU)
      IF (IERR.NE.0) GOTO 9999
C
C**** On cherche le pointeur de son maillage et on l'impose sur les
C     autres CHPOINT
C
      MCHPOI = IPHI
      SEGACT MCHPOI
      MSOUPO = MCHPOI.IPCHP(1)
      SEGACT MSOUPO
      ICEN = MSOUPO.IGEOC
      SEGDES MSOUPO
      SEGDES MCHPOI
C
C**** Control du CHPOINT: QUEPOI
C
C     On controlle que le chpoint est non-partitione
C
C     INDIC = 1   -> on impose le pointeur du support geometrique (ICEN)
C     INDIC = 0   -> on ne fait que verifier le support geometrique (ICEN)      
C
C     NBCOMP > 0 -> numero des composantes      
C
C     MOT(1) = ' ' obligatoire s'on connais pas les noms des composantes
C
      INDIC = 1
      NBCOMP = 1
      MOT(1) = 'SCAL'
      CALL QUEPOI(IPHI, ICEN, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR = 'CHPO0 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)         

         GOTO 9999
      ENDIF  
C      
C**** Lecture du CHPOINT RO
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',IRO,ICOND,IRETOU)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C     
      INDIC = 1
      NBCOMP = 1
      MOT(1) = 'SCAL'
      CALL QUEPOI(IRO, ICEN, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO1 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF 
C      
C**** Lecture du CHPOINT DEBIT.
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',IROVIT,ICOND,IRETOU)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C     
      INDIC = 1
      NBCOMP = IDIM
      JGN = 4
      JGM = IDIM
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'UX  '
      MLMOTS.MOTS(2) = 'UY  '
      IF(IDIM .EQ. 3) MLMOTS.MOTS(3) = 'UZ  '
      CALL QUEPO1(IROVIT, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO2 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)         

         GOTO 9999
      ENDIF  
      SEGSUP MLMOTS
C      
C**** Lecture du CHPOINT ROET
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',IROET,ICOND,IRETOU)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C     
      INDIC = 1
      NBCOMP = 1
      MOT(1) = 'SCAL'
      CALL QUEPOI(IROET, ICEN, INDIC, NBCOMP, MOT)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO3 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF 
C      
C**** Lecture du CHPOINT IROY and IALP
C
      IF (NESP .GE. 1) THEN
         ICOND = 1
         CALL LIROBJ('CHPOINT',IROY,ICOND,IRETOU)
         IF (IERR.NE.0) GOTO 9999
C
C
C**** Control du CHPOINT
C     
         CALL QUEPO1(IROY , ICEN , MLMOT1)
         IF(IERR .NE. 0)THEN

C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
            MOTERR = 'CHPO4 = ???                             '
            WRITE(IOIMP,*) MOTERR(1:40)
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
            CALL ERREUR(21)
            GOTO 9999
         ENDIF
C
         ICOND = 1
         CALL LIROBJ('CHPOINT',IALP,ICOND,IRETOU)
         IF (IERR.NE.0) GOTO 9999
C
C
C**** Control du CHPOINT
C     
         CALL QUEPO1(IALP , ICEN , MLMOT1)
         IF(IERR .NE. 0)THEN

C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
            MOTERR = 'CHPO5 = ???                             '
            WRITE(IOIMP,*) MOTERR(1:40)
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
            CALL ERREUR(21)
            GOTO 9999
         ENDIF
      ELSE
         IROY = 0
         IALP = 0
      ENDIF
C
C
C******* Option TRICHE
C
      ICOND = 0
      CALL LIRCHA(NOMTRI,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(IRETOU .EQ. 0)THEN
         LOGTRI = .FALSE.
      ELSEIF(NOMTRI .EQ. 'TRICHE')THEN
         LOGTRI  = .TRUE.
      ELSE
         LOGTRI = .FALSE.
         CALL ECRCHA(NOMTRI)
      ENDIF
C
C**** Calcul des sorties.
C
      CALL PRGFM1(NESP,
     &     ICEN,IPHI,IRO,IROVIT,IROET,IROY,IALP,
     &     MLRMGA,MLRPGA,MLRMPI,MLRPPI,
     &     IVIT,IPRES,IY,
     &     LOGNEG,MESERR,
     &     VALER)
C
      IF(LOGNEG)THEN
C
C******* Pression (energie thermique)  ou densité negative
C
C
C******* Message d'erreur standard
C        41 2
C        %m1:8 = %r1 inférieur à %r2
C
         MESCEL = MESERR(1)
         MOTERR(1:8) = MESCEL(1:8)
         REAERR(1) = REAL(VALER(1))
         REAERR(2) = 0.0
         CALL ERREUR(41)
         IF(LOGTRI)THEN
            IERR = 0
         ELSE
            GOTO 9999
         ENDIF
      ENDIF
      IF (NESP .GE. 1) THEN
         CALL ECROBJ('CHPOINT',IY)
      ENDIF
C
C**** Ecriture du CHPOINT contenant la pression.
C
      CALL ECROBJ('CHPOINT',IPRES)
C
C**** Ecriture du CHPOINT contenant la vitesse.
C
      CALL ECROBJ('CHPOINT',IVIT)
C
      SEGDES MLRMPI
      SEGDES MLRMGA
      SEGDES MLRPPI
      SEGDES MLRPGA
C
 9999 CONTINUE
C      
      RETURN                                                                    
      END