Télécharger prigfm.eso

Retour à la liste

prigfm
C PRIGFM    SOURCE    OF166741  24/12/13    21:17:11     12097          
      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**** 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 PPARAM
-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)
         CALL ACTOBJ(MTYPR,IPGAS,1)
         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)
      CALL ACTOBJ('CHPOINT',IPHI,1)
      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)
      CALL ACTOBJ('CHPOINT ',IRO,1)
      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)
      CALL ACTOBJ('CHPOINT ',IROVIT,1)
      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)
      CALL ACTOBJ('CHPOINT ',IROET,1)
      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)
         CALL ACTOBJ('CHPOINT ',IROY,1)
         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)
         CALL ACTOBJ('CHPOINT ',IALP,1)
         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 ACTOBJ('CHPOINT ',IY,1)
         CALL ECROBJ('CHPOINT ',IY)
      ENDIF
C
C**** Ecriture du CHPOINT contenant la pression.
C
      CALL ACTOBJ('CHPOINT ',IPRES,1)
      CALL ECROBJ('CHPOINT ',IPRES)
C
C**** Ecriture du CHPOINT contenant la vitesse.
C
      CALL ACTOBJ('CHPOINT ',IVIT,1)
      CALL ECROBJ('CHPOINT ',IVIT)
C
C
 9999 CONTINUE
      END
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales