Télécharger pre31.eso

Retour à la liste

pre31
C PRE31     SOURCE    OF166741  24/12/13    21:17:04     12097          
      SUBROUTINE PRE31()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRE31
C
C DESCRIPTION       :  Voir PRE3
C
C                      Cas gaz "thermally perfect" mono/multi-especes
C
C                      1er ordre en espace, 1er ordre en temps
C
C                      Creations des object MCHAML IROF, IVITF, IPF, IYF
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 (Outils)  :  LIRTAB, ACMO, LEKTAB, QUETYP, ERREUR, LIROBJ,
C                      QUEPO1, ECROBJ
C
C APPELES (Calcul)  :  PRE311 (2D), PRE312 (3D)
C
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE :  Créée le 18.12.98.
C
C               06.02.00 transport des scalaires passifs
C
C************************************************************************
C
C**** Les variables
C
      IMPLICIT INTEGER(I-N)
      INTEGER   ICOND,  IRETOU, IERR0
     &     ,IDOMA, ICEN, IFACE, IFACEL, INORM, IROC, IVITC, IPC
     &     ,IYC, ISCAC, IROF, IVITF, IPF, IYF,  IPGAS, NESP, ISCAF
     &     ,NSCA, INEFMD
     &     ,MMODEL
      REAL*8 VALER, VAL1, VAL2
      CHARACTER*(8) MTYPR, TYPE
      CHARACTER*(40) MESERR
      LOGICAL LOGAN,LOGNEG, LOGBOR
C
C**** Les Includes
C
 
-INC PPARAM
-INC CCOPTIO
      INTEGER JGM, JGN
-INC SMLMOTS
      POINTEUR MLMCOM.MLMOTS, MLMESP.MLMOTS, MLMSCA.MLMOTS
      POINTEUR MLMVIT.MLMOTS
C
C**** Initialisation des parametres d'erreur
C
      LOGAN = .FALSE.
      LOGNEG  = .FALSE.
      LOGBOR  = .FALSE.
      MESERR = '                                        '
      MOTERR(1:40) = MESERR(1:40)
      VALER = 0.0D0
      VAL1 = 0.0D0
      VAL2 = 0.0D0
C
C**** Lecture de l'objet MODELE
C
      ICOND = 1
      CALL QUETYP(TYPE,ICOND,IRETOU)
      CALL LIROBJ('MMODEL  ',MMODEL,ICOND,IRETOU)
      CALL ACTOBJ('MMODEL  ',MMODEL,1)
      IF(IERR.NE.0)GOTO 9999
      CALL LEKMOD(MMODEL,IDOMA,INEFMD)
      IF(IERR.NE.0)GOTO 9999
C
C**** Lecture du MELEME SPG des points CENTRE.
C
C
C     CALL LEKTAB(IDOMA,'CENTRE',IP)
C
C**** Probleme du LEKTAB: si IDOMA.'CENTRE' n'existe pas,
C     il crèe IDOMA.'CENTRE' sans recrèer 'FACEL'
C     -> la correspondance global des noeuds saut!
C
C     On peut utilizer ACCTAB ou ACMO
C
      MTYPR = 'MAILLAGE'
      CALL ACMO(IDOMA,'CENTRE',MTYPR,ICEN)
      IF(IERR.NE.0)GOTO 9999
C
C**** Lecture du MELEME 'FACE'
C
      MTYPR = 'MAILLAGE'
      CALL ACMO(IDOMA,'FACE',MTYPR,IFACE)
      IF(IERR.NE.0)GOTO 9999
C
C**** Lecture du MELEME 'FACEL'
C
      MTYPR = 'MAILLAGE'
      CALL ACMO(IDOMA,'FACEL',MTYPR,IFACEL)
      IF(IERR.NE.0)GOTO 9999
C
C**** Lecture du CHPOINT contenant les normales (tangentes)  aux faces
C
      IF(IDIM .EQ. 2)THEN
C        Que les normales
         CALL LEKTAB(IDOMA,'XXNORMAF',INORM)
         IF(IERR .NE. 0) GOTO 9999
         JGN = 4
         JGM = 2
         SEGINI MLMVIT
         MLMVIT.MOTS(1) = 'UX  '
         MLMVIT.MOTS(2) = 'UY  '
         CALL QUEPO1(INORM, IFACE, MLMVIT)
         SEGSUP MLMVIT
         IF(IERR.NE.0)GOTO 9999
      ELSE
         MTYPR = ' '
         CALL ACMO(IDOMA,'MATROT',MTYPR,INORM)
         IF (MTYPR .NE. 'CHPOINT ') THEN
            CALL MATRAN(IDOMA,INORM)
            IF(IERR .NE. 0) GOTO 9999
         ENDIF
         JGN = 4
         JGM = 9
         SEGINI MLMVIT
         MLMVIT.MOTS(1) = 'UX  '
         MLMVIT.MOTS(2) = 'UY  '
         MLMVIT.MOTS(3) = 'UZ  '
         MLMVIT.MOTS(4) = 'RX  '
         MLMVIT.MOTS(5) = 'RY  '
         MLMVIT.MOTS(6) = 'RZ  '
         MLMVIT.MOTS(7) = 'MX  '
         MLMVIT.MOTS(8) = 'MY  '
         MLMVIT.MOTS(9) = 'MZ  '
         CALL QUEPO1(INORM, IFACE, MLMVIT)
         SEGSUP MLMVIT
         IF(IERR.NE.0)GOTO 9999
C
      ENDIF
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 especes qui sont dans les Equations d'Euler
C
      MTYPR = '        '
      CALL ACMO(IPGAS,'ESPEULE',MTYPR,MLMESP)
      IF(MTYPR .EQ. '        ')THEN
         NESP = 0
         IYC = 0
      ELSEIF(MTYPR .NE. 'LISTMOTS')THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'TAB2 . ESPEULE = ???                    '
         WRITE(IOIMP,*) MOTERR
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ELSE
         SEGACT MLMESP
         NESP = MLMESP.MOTS(/2)
         SEGDES MLMESP
      ENDIF
C
C**** Les scalaires passifs
C
      MTYPR = '        '
      CALL ACMO(IPGAS,'SCALPASS',MTYPR,MLMSCA)
      IF(MTYPR .EQ. '        ')THEN
         NSCA = 0
         ISCAC = 0
      ELSEIF(MTYPR .NE. 'LISTMOTS')THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'TAB2 . SCALPASS = ???                   '
         WRITE(IOIMP,*) MOTERR
C
C******* Message d'erreur standard
C        21 2
C        Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ELSE
         SEGACT MLMSCA
         NSCA = MLMSCA.MOTS(/2)
         SEGDES MLMSCA
      ENDIF
C
C**** Lecture du CHPOINT ROC
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,IROC,ICOND,IRETOU)
         CALL ACTOBJ(MTYPR,IROC,1)
         IF (IERR.NE.0) GOTO 9999
      ENDIF
C
C**** Control du CHPOINT: QUEPO1
C
      JGN=4
      JGM=1
      SEGINI MLMCOM
      MLMCOM.MOTS(1)='SCAL'
      CALL QUEPO1(IROC, ICEN, MLMCOM)
      SEGSUP MLMCOM
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'CHPO1 = ???                             '
     $
         WRITE(IOIMP,*) MOTERR
 
         GOTO 9999
      ENDIF
C
C**** Lecture du CHPOINT VITC
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('CHPOINT',IVITC,ICOND,IRETOU)
         CALL ACTOBJ('CHPOINT',IVITC,1)
         IF (IERR.NE.0) GOTO 9999
      ENDIF
C
C**** Control du CHPOINT
C
      JGN=4
      JGM=IDIM
      SEGINI MLMCOM
      MLMCOM.MOTS(1) = 'UX  '
      MLMCOM.MOTS(2) = 'UY  '
      IF(IDIM .EQ. 3) MLMCOM.MOTS(3) = 'UZ  '
      CALL QUEPO1(IVITC, ICEN, MLMCOM)
      SEGSUP MLMCOM
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'CHPO2 = ???                             '
     $
         WRITE(IOIMP,*) MOTERR
 
         GOTO 9999
      ENDIF
C
C**** Lecture du CHPOINT PC
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('CHPOINT',IPC,ICOND,IRETOU)
         CALL ACTOBJ('CHPOINT',IPC,1)
         IF (IERR.NE.0) GOTO 9999
      ENDIF
C
C**** Control du CHPOINT
C
      JGN=4
      JGM=1
      SEGINI MLMCOM
      MLMCOM.MOTS(1)='SCAL'
      CALL QUEPO1(IPC, ICEN, MLMCOM)
      SEGSUP MLMCOM
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'CHPO3 = ???                             '
     $
         WRITE(IOIMP,*) MOTERR
 
         GOTO 9999
      ENDIF
C
C**** Lecture du CHPOINT YC
C
      IF(NESP .GT. 0)THEN
         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('CHPOINT',IYC,ICOND,IRETOU)
            CALL ACTOBJ('CHPOINT',IYC,1)
            IF (IERR.NE.0) GOTO 9999
         ENDIF
C
C**** Control du CHPOINT (on ne controlle que le maillage)
C
         CALL QUEPO1(IYC, ICEN, MLMESP)
         IF(IERR .NE. 0)THEN
            IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
            MOTERR(1:40) = 'CHPO4 = ???                             '
            WRITE(IOIMP,*) MOTERR
 
            GOTO 9999
         ENDIF
      ENDIF
C
C**** Lecture du CHPOINT ISCAC
C
      IF(NSCA .GT. 0)THEN
         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('CHPOINT',ISCAC,ICOND,IRETOU)
            CALL ACTOBJ('CHPOINT',ISCAC,1)
            IF (IERR.NE.0) GOTO 9999
         ENDIF
C
C**** Control du CHPOINT (on ne controlle que le maillage)
C
         CALL QUEPO1(ISCAC, ICEN, MLMSCA)
         IF(IERR .NE. 0)THEN
            IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
            MOTERR(1:40) = 'CHPO5 = ???                             '
            WRITE(IOIMP,*) MOTERR
 
            GOTO 9999
         ENDIF
      ENDIF
C
C**** Centre -> Face
C
      IF(IDIM .EQ. 2)THEN
C
C******* Deux Dimensions, Mono/Multi Especes, 1er ordre en espace, 1er ordre en
C        temps
C
         CALL PRE311(ICEN,IFACE,IFACEL,INORM,IROC,IVITC,IPC,IYC,ISCAC,
     &        IROF,IVITF,IPF,IYF,ISCAF,
     &        LOGAN,LOGNEG,LOGBOR,MESERR,VALER,VAL1,VAL2)
      ELSE
C
C******* Trois Dimensions, Mono/Multi Especes, 1er ordre en espace,
C 1er ordre en temps
C
C
         CALL PRE312(ICEN,IFACE,IFACEL,INORM,IROC,IVITC,IPC,IYC,ISCAC,
     &        IROF,IVITF,IPF,IYF,ISCAF,
     &        LOGAN,LOGNEG,LOGBOR,MESERR,VALER,VAL1,VAL2)
      ENDIF
C
C**** Messages d'erreur
C
      IF(LOGAN)THEN
C
C******* Anomalie detectée
C
C
C******* Message d'erreur standard
C        -301 0
C        %m1:40
C
         MOTERR(1:40) =  MESERR(1:40)
         WRITE(IOIMP,*) MOTERR
C
C******* Message d'erreur standard
C        5 3
C        Erreur anormale.contactez votre support
C
         CALL ERREUR(5)
         GOTO 9999
C
      ELSEIF(LOGNEG)THEN
C
C******* Message d'erreur standard
C        41 2
C        %m1:8 = %r1 inférieur à %r2
C
         MOTERR(1:8) = MESERR(1:8)
         REAERR(1) = REAL(VALER)
         REAERR(2) = 0.0
         CALL ERREUR(41)
         GOTO 9999
      ELSEIF(LOGBOR)THEN
C
C******* Message d'erreur standard
C        42 2
C        %m1:8 = %r1 non compris entre %r2 et %r3
C
         MOTERR(1:8) = MESERR(1:8)
         REAERR(1) = REAL(VALER)
         REAERR(2) = REAL(VAL1)
         REAERR(3) = REAL(VAL2)
         CALL ERREUR(42)
         GOTO 9999
      ELSE
C
C******* Ecriture de ROF, VITF, PF, YF, GAMMAF
C
         MTYPR = 'MCHAML  '
         IF(ISCAF .NE. 0) THEN
           CALL ACTOBJ(MTYPR,ISCAF,1)
           CALL ECROBJ(MTYPR,ISCAF)
         ENDIF
         IF(IYF   .NE. 0) THEN
           CALL ACTOBJ(MTYPR,IYF,1)
           CALL ECROBJ(MTYPR,IYF)
         ENDIF
         CALL ACTOBJ(MTYPR,IPF,1)
         CALL ACTOBJ(MTYPR,IVITF,1)
         CALL ACTOBJ(MTYPR,IROF,1)
 
         CALL ECROBJ(MTYPR,IPF)
         CALL ECROBJ(MTYPR,IVITF)
         CALL ECROBJ(MTYPR,IROF)
      ENDIF
C
 9999 CONTINUE
      END
 
 
 
 

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