Télécharger primme.eso

Retour à la liste

primme
C PRIMME    SOURCE    CB215821  20/11/25    13:36:58     10792          
      SUBROUTINE PRIMME()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRIMME
C
C DESCRIPTION       :  Voir PRIMIT
C
C                      Calcul des variables primitives (et du "gamma")
C                      pour les gaz "calorically perfect" multiespeces
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)     : QUETYP, ACMO, LIROBJ, QUEPOI, ERREUR, ECROBJ,
C                     QUEPO1, ACCTAB, LIRCHA, ECRCHA
C
C APPELES (Calcul)  : PRMECA
C
C
C************************************************************************
C
C
C PHRASE D'APPEL (GIBIANE) :
C
C 2) gaz parfait multi-especes (NESP > 1)
C
C  RCHPO1 RCHPO2 RCHPO3 RCHPO4 RCHPO5 = 'PRIM' MCLE1  TAB1
C                CHPO1 CHPO2 CHPO3 CHPO4 (MCLE2) ;
C
C
C ENTREES  :
C
C            MCLE1   : 'PERFMULT'  : mot clé
C
C
C            TAB1    : TABLE qui contient :
C                      * les noms des especes qui apparessent
C                        explicitement dans les equations d'Euler en
C                         TAB1 . 'ESPEULE' (list de mots);
C                      * le nom de l'espece qui n'y est pas (mots);
C                      * les CP et les CV du gas en
C                         TAB1 . 'CP' (table)
C                         TAB1 . 'CV' (table)
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  contenat l'énergie totale per
C                      unité de volume (RHO Et),
C                      (une composante, 'SCAL').
C
C            CHPO4   : CHPOINT  contenant la masse des especes qui
C                      explicitement "splitted" dans les equations
C                      d'Eulers (dont les noms sont dans
C                      TAB1 . 'ESPEULE');
C
C            i.e.  CHPO1, CHPO2, CHPO3, CHPO4 sont les variables
C                  conservatives  des Equations d'Euler.
C
C            MCLE2   : Option personelle: pas dans la notice
C                      officielle!!!
C                      Mot clé, 'TRICHE' (s'il y a un erreur,
C                      les resultats ne sont pas
C                      des type ANNULLE et le programme
C                      ne s'arrete pas!!!)
C
C SORTIES  :
C
C            RCHPO1  : CHPOINT  contenant la vitesse
C
C            RCHPO2  : CHPOINT  contenant la pression du gaz;
C
C            RCHPO3  : CHPOINT  contenant la temperature du  gaz;
C
C            RCHPO4  : CHPOINT  contenant les fractions
C                      massiques des differentes especes;
C
C            RCHPO5  : CHPOINT  contenat les "gamma" du gaz
C
C            N.B.:-tous les CHPOINTs sont non-partitonees et
C                  ils ont le meme support geometrique;
C                  en sortie tous les CHPOINTs ont le support
C                  geometrique de RO
C                 -en sortie RCHPO5 a le composantes ordonnees
C                  en tal sens:
C                  TAB1 . 'ESPEULE' + TAB1 . 'ESPNEULE'
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE :  Créée le 12.1.98.
C
C               Modifie le 30.7.98 pour ajouter le mot clee personelle
C               'TRICHE'
C
C               Modifie le 1.2.99 pour precedente use impropre de la
C               subroutine  ACMM
C
C               Modifie le 28.09.00 pour control sur le noms de composantes
C               (subroutine  QUEPO1)
C               Variables de CCOPTIO en commentaire
C               Elimination de ERREUR(-301)
C
C************************************************************************
C
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 ICOND, IRETOU, INDIC, NBCOMP, IERR0
     &       , NESP,  ICEN, IRO, IROVIT, IROET, IROY
     &       , IPGAS, ICP, ICV
     &       , IPRES, IVIT, ITEMP, IY, IGAM
     &       , I1,  JG, JGM, JGN
      REAL*8 VALER(2),VAL1,VAL2,CP,CV
      CHARACTER*(40) MESERR(2),MESCEL
      CHARACTER*(8) MTYPR
      CHARACTER*(6) NOMTRI
      CHARACTER*(4)  MOT1(3), CELLCH
      LOGICAL LOGNEG, LOGBOR, LOGAN, LOGTRI
C
C**** Variables en ACCTAB
C
      INTEGER IVALI, IRETI,IVALR, IRETR
      REAL*8 XVALI,XVALR
      LOGICAL LOGII, LOGIR
      CHARACTER*(8) CHARR,MTYPI
C
C**** Segment pour ordoner les composantes
C
      SEGMENT ORDO
         INTEGER IORDO(NC)
      ENDSEGMENT
C
C**** Les Includes
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
-INC SMLREEL
      POINTEUR MLRECP.MLREEL, MLRECV.MLREEL
C
C**** Initialisation des parametres d'erreur
C
      LOGAN   = .FALSE.
      LOGNEG  = .FALSE.
      LOGBOR  = .FALSE.
      MESCEL  = '                                        '
      MESERR(1) = MESCEL
      MESERR(2) = MESCEL
      MOTERR(1:40) = MESCEL(1:40)
      VALER(1) = 0.0D0
      VALER(2) = 0.0D0
      VAL1 = 0.0D0
      VAL2 = 0.0D0
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**** Initialisation des MOT1(1) (noms des composantes)
C
      MOT1(1) = '    '
C
C**** N.B. On veut lire les objets sequentiellement.
C     Donc on utilise QUETYP pour controler que
C     le type de l'objet soit le bon.
C
C**** Lecture de la table des proprietes du gaz
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**** Les CPs
C
      MTYPR = '        '
      CALL ACMO(IPGAS,'CP',MTYPR,ICP)
      IF(MTYPR .NE. 'TABLE   ')THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'TAB1 . CP = ???                         '
         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 CVs
C
      MTYPR = '        '
      CALL ACMO(IPGAS,'CV',MTYPR,ICV)
      IF(MTYPR .NE. 'TABLE   ')THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'TAB1 . CV = ???                         '
         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
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 ,CELLCH,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**** Control de compatibilite des donnes de la table
C     et creation des LISTREELs avec CP et CV
C
      SEGACT MLMOT1
      NESP = MLMOT1.MOTS(/2)
C
C**** List de CP et CV
C
      JG = NESP+1
      SEGINI MLRECP
      SEGINI MLRECV
      DO I1 = 1, NESP
C
C******* N.B. MOT1 est un CHARACTER*(4)
C
         MOT1(1) = MLMOT1.MOTS(I1)
C
C******* CALL ACMF(ICP,NOMC,CP)  ne marche pas parce que on a
C        des blanches dans nos composantes
C
         MTYPI = 'MOT     '
         MTYPR = '        '
         CALL ACCTAB(ICP,MTYPI,IVALI,XVALI,MOT1(1), LOGII,IRETI,
     &               MTYPR,IVALR,CP   ,CHARR,LOGIR,IRETR)
         IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
            MOTERR = 'TAB1 . CP , 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
         MLRECP.PROG(I1) = CP
C
         MTYPI = 'MOT     '
         MTYPR = '        '
         CALL ACCTAB(ICV,MTYPI,IVALI,XVALI,MOT1(1), LOGII,IRETI,
     &               MTYPR,IVALR,CV   ,CHARR,LOGIR,IRETR)
         IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
            MOTERR = 'TAB1  . CV , 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
         MLRECV.PROG(I1) = CV
      ENDDO
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(ICP,MTYPI,IVALI,XVALI,CELLCH, LOGII,IRETI,
     &            MTYPR,IVALR,CP   ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
C
C******* Message d'erreur standard
C           -301 0 %m1:40
C
         MOTERR = 'TAB1  . CP , 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
      MLRECP.PROG(JG) = CP
C
      MTYPI = 'MOT     '
      MTYPR = '        '
      CALL ACCTAB(ICV,MTYPI,IVALI,XVALI,CELLCH, LOGII,IRETI,
     &            MTYPR,IVALR,CV   ,CHARR,LOGIR,IRETR)
      IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR = 'TAB1 . CV , 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
      MLRECV.PROG(JG) = CV
C
C**** Lecture du CHPOINT CHPO1 (masse volumique totale)
C
      ICOND = 1
      CALL QUETYP(MTYPR,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(MTYPR .NE. 'CHPOINT ')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) = 'CHPOINT '
         CALL ERREUR(37)
         GOTO 9999
      ELSE
         ICOND = 1
         CALL LIROBJ(MTYPR,IRO,ICOND,IRETOU)
         CALL ACTOBJ(MTYPR,IRO,1)
         IF(IERR .NE. 0)GOTO 9999
      ENDIF
C
C**** On cherche le pointeur de son maillage et on l'impose sur les
C     autres CHPOINTs
C
      MCHPOI = IRO
      SEGACT MCHPOI
      MSOUPO = MCHPOI.IPCHP(1)
      SEGACT MSOUPO
      ICEN = MSOUPO.IGEOC
      SEGDES MSOUPO
      SEGDES MCHPOI
C
C**** Control du CHPOINT: QUEPOI
C
C     INDIC = 1   -> on impose le pointeur du support geometrique (ICEN)
C                   N.B. Le CHPOINT peut changer de structure pour
C                        avoir SPG = ICEN!!!!
C     INDIC = 0   -> on ne fait que verifier le support geometrique
C                   (ICEN). Si le SPG sont differents INDIC = -4 en sortie
C
C     NBCOMP > 0 -> numero des composantes
C
C     MOT1(1) = ' ' obligatoire s'on connais pas les noms des composantes
C
      INDIC = 1
      NBCOMP = 1
      MOT1(1) = 'SCAL'
      CALL QUEPOI(IRO, ICEN, INDIC, NBCOMP, MOT1)
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
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 CHPO2( debits)
C
      ICOND = 1
      CALL QUETYP(MTYPR,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(MTYPR .NE. 'CHPOINT ')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) = 'CHPOINT '
         CALL ERREUR(37)
         GOTO 9999
      ELSE
         ICOND = 1
         CALL LIROBJ(MTYPR,IROVIT,ICOND,IRETOU)
         CALL ACTOBJ(MTYPR,IROVIT,1)
         IF(IERR .NE. 0)GOTO 9999
      ENDIF
C
C**** Control du CHPOINT
C
      INDIC = 1
      NBCOMP = IDIM
      JGN = 4
      JGM = IDIM
      SEGINI MLMOT2
      MLMOT2.MOTS(1) = 'UX  '
      MLMOT2.MOTS(2) = 'UY  '
      IF(IDIM .EQ. 3) MLMOT2.MOTS(3) = 'UZ  '
      CALL QUEPO1(IROVIT, ICEN, MLMOT2)
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR = 'CHPO2                                   '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
C
C**** Lecture du CHPOINT CHPO3(energie volumique)
C
      ICOND = 1
      CALL QUETYP(MTYPR,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(MTYPR .NE. 'CHPOINT ')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) = 'CHPOINT '
         CALL ERREUR(37)
         GOTO 9999
      ELSE
         ICOND = 1
         CALL LIROBJ(MTYPR,IROET,ICOND,IRETOU)
         CALL ACTOBJ(MTYPR,IROET,1)
         IF(IERR .NE. 0)GOTO 9999
      ENDIF
C
C**** Control du CHPOINT
C
      INDIC = 1
      NBCOMP = 1
      MOT1(1) = 'SCAL'
      CALL QUEPOI(IROET, ICEN, INDIC, NBCOMP, MOT1)
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
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 CHPO4(masses volumiques des especes "splittees")
C
      ICOND = 1
      CALL QUETYP(MTYPR,ICOND,IRETOU)
      IF(IERR .NE. 0)GOTO 9999
      IF(MTYPR .NE. 'CHPOINT ')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) = 'CHPOINT '
         CALL ERREUR(37)
         GOTO 9999
      ELSE
         ICOND = 1
         CALL LIROBJ(MTYPR,IROY,ICOND,IRETOU)
         CALL ACTOBJ(MTYPR,IROY,1)
         IF(IERR .NE. 0)GOTO 9999
      ENDIF
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
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
C     Jusque a la NESP = nombre d'especes qui apparessent
C     dans les equations d'Euler
C
C     Maintenant NESP = nombre total d'espece
C
      NESP = NESP + 1
      CALL PRMECA(NESP,
     &            ICEN,IRO,IROVIT,IROET,IROY,MLRECP,MLRECV,
     &            IVIT,IPRES,ITEMP,IY,IGAM,
     &            LOGAN,LOGNEG,LOGBOR,MESERR,
     &            VALER,VAL1,VAL2)
C
      IF(LOGAN)THEN
C
C******* Message d'erreur standard
C        5 3
C        Erreur anormale.contactez votre support
C
         CALL ERREUR(5)
         GOTO 9999
      ELSE
         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(LOGBOR)THEN
C
C******* GAMMA !\in  GAMMIN, GAMMAX
C        ou Y !\in YMIN,YMAX
C
C******* Message d'erreur standard
C        42 2
C        %m1:8 = %r1 non compris entre %r2 et %r3
C
            MESCEL = MESERR(2)
            MOTERR(1:8) = MESCEL(1:8)
            REAERR(1) = REAL(VALER(2))
            REAERR(2) = REAL(VAL1)
            REAERR(3) = REAL(VAL2)
            CALL ERREUR(42)
            IF(LOGTRI)THEN
*               IERR = 0
            ELSE
               GOTO 9999
            ENDIF
         ENDIF
 
         CALL ACTOBJ('CHPOINT ',IGAM ,1)
         CALL ACTOBJ('CHPOINT ',IY   ,1)
         CALL ACTOBJ('CHPOINT ',ITEMP,1)
         CALL ACTOBJ('CHPOINT ',IPRES,1)
         CALL ACTOBJ('CHPOINT ',IVIT ,1)
 
C******* Ecriture du CHPOINT contenant les "gamma".
         CALL ECROBJ('CHPOINT ',IGAM)
 
C******* Ecriture du CHPOINT contenant Y.
         CALL ECROBJ('CHPOINT ',IY)
 
C******* Ecriture du CHPOINT contenant la temperature.
         CALL ECROBJ('CHPOINT ',ITEMP)
 
C******* Ecriture du CHPOINT contenant la pression.
         CALL ECROBJ('CHPOINT ',IPRES)
 
C******* Ecriture du CHPOINT contenant la vitesse.
         CALL ECROBJ('CHPOINT ',IVIT)
 
      ENDIF
 
      SEGSUP MLRECV
      SEGSUP MLRECV
      SEGSUP MLMOT2
      SEGDES MLMOT1
 
 9999 CONTINUE
 
      END
 
 
 
 

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