Télécharger flacr2.eso

Retour à la liste

flacr2
C FLACR2    SOURCE    OF166741  24/12/13    21:15:51     12097          
      SUBROUTINE FLACR2()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  FLACR2
C
C DESCRIPTION       :  CREBCOM: modele non-homogene
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI, DM2S/SFME/LTMF
C
C************************************************************************
C
C
C************************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE :
C
C
C************************************************************************
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMLMOTS
      POINTEUR MLMESP.MLMOTS
-INC SMLREEL
      POINTEUR MLRECO.MLREEL, MLRMAS.MLREEL, MLRH0K.MLREEL
C
      INTEGER JGN, JGM, JG
C
C**** Les variables
C
      INTEGER IDOMA,IRET,MELEMC,MELEFE,IPGAS,IESP,NESP,NESP1
     &     ,IRC,IYC,IYINIT,IYFINA,IVCAR,ICHRET,ICHRYN,IERR0,I1
     &     ,IDX,MMODEL
 
      REAL*8 RGAS, EPS1, DELTAT, EPSCSI
      PARAMETER(RGAS=8.31441D0)
      CHARACTER*8 TYPE
      CHARACTER*4 MOT1(1)
C
C**** Variables en ACCTAB
C
      INTEGER IVALI, IRETI,IVALR, IRETR
      REAL*8 XVALI, XVALR
      LOGICAL LOGII, LOGIR
      CHARACTER*(8) CHARR,MTYPI,MTYPR
C
C**** Lecture de l'objet MODELE
C
      ICOND = 1
      CALL QUETYP(TYPE,ICOND,IRET)
 
      IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN
        WRITE(6,*)' On attend un objet MMODEL'
        RETURN
      ENDIF
      CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET)
      IF(IERR.NE.0)GOTO 9999
      CALL LEKMOD(MMODEL,IDOMA,INEFMD)
      IF(IERR.NE.0)GOTO 9999
C
C**** CENTRE, et FACEL
C
      CALL LEKTAB(IDOMA,'CENTRE',MELEMC)
      IF(IERR .NE. 0) GOTO 9999
C
      CALL LEKTAB(IDOMA,'FACEL',MELEFE)
      IF(IERR .NE. 0) GOTO 9999
C
C**** La reaction chimique
C     Noms des especes qui interviennent
C
      TYPE='LISTMOTS'
      CALL LIROBJ(TYPE,MLMESP,1,IRET)
      IF(IERR .NE. 0)GOTO 9999
      SEGACT MLMESP
      NESP=MLMESP.MOTS(/2)
C
C**** Les coeff. stoich.
C     Ils sont positifs pour les reactants
C              negatives pour les produits
C
      TYPE='LISTREEL'
      CALL LIROBJ(TYPE,MLRECO,1,IRET)
      IF(IERR .NE. 0)GOTO 9999
      SEGACT MLRECO
      NESP1=MLRECO.PROG(/1)
      IF(NESP1 .NE. NESP)THEN
         MOTERR(1:40)='LMOT1 = ???                             '
         WRITE(IOIMP,*) MOTERR
         MOTERR(1:40)='LREE1 = ???                             '
         WRITE(IOIMP,*) MOTERR
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C**** La LISTREEL des poids molaires MLRMAS
C                 des énergies de formation à 0K
C                 MLRH0K
C
      JG=NESP
      SEGINI MLRMAS
      SEGINI MLRH0K
C
C************************************************
C**** La table des proprietés des gaz ***********
C************************************************
C
      TYPE='TABLE   '
      CALL LIROBJ(TYPE,IPGAS,1,IRET)
      IF(IERR .NE. 0)GOTO 9999
      DO I1 = 1, NESP, 1
         MOT1(1) = MLMESP.MOTS(I1)
C
C******* CALL ACMF(...)  ne marche pas parce que on a
C        des blanches dans nos composantes
C
         MTYPI = 'MOT     '
         MTYPR = '        '
         CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,MOT1(1), LOGII,IRETI,
     &                     MTYPR,IVALR,XVALR,CHARR,LOGIR,IESP)
C
C******* En IESP a la table IPGAS.MOT1(1)
C
         IF((IERR .NE. 0) .OR. (MTYPR .NE. 'TABLE   ')) THEN
 
C
C********** Message d'erreur standard
C           -301 0 %m1:40
C
            MOTERR = '                                        '
            MOTERR(1:7) = 'TAB2 . '
            MOTERR(8:11) = MOT1(1)
            MOTERR(13:17) = '= ???'
            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******* R
C
         MTYPI = 'MOT     '
         MTYPR = '        '
         CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'R' , LOGII,IRETI,
     &                    MTYPR,IVALR, XVALR ,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 = '                                        '
            MOTERR(1:7) = 'TAB2 . '
            MOTERR(8:11) = MOT1(1)
            MOTERR(13:23) = ' . R = ??? '
            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
         MLRMAS.PROG(I1)=RGAS/XVALR
C
C******* H0K
C
         MTYPI = 'MOT     '
         MTYPR = '        '
         CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'H0K' , LOGII,IRETI,
     &                    MTYPR,IVALR, XVALR ,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 = '                                        '
            MOTERR(1:7) = 'TAB2 . '
            MOTERR(8:11) = MOT1(1)
            MOTERR(13:25) = ' . H0K = ??? '
            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
         MLRH0K.PROG(I1)=XVALR
      ENDDO
C
C**** Les CHPOINT densité
C
      CALL LIROBJ('CHPOINT',IRC,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C     IRC ordonné selon MLECEN
C
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='SCAL'
      CALL QUEPO1(IRC, MELEMC, MLMOT1)
      SEGSUP MLMOT1
      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**** Les CHPOINTs des fractions massiques des especes
C
      CALL LIROBJ('CHPOINT',IYC,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C     IYC ordonné selon MELEMC et MLMESP
C
      CALL QUEPO1(IYC, MELEMC, MLMESP)
C     Attention: MLMESP desactivé en sortie de QUEPO1
      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**** Les CHPOINTs des fractions massiques initiale et finale de
C     l'espece en MLMESP.MOTS(1)
C
      CALL LIROBJ('CHPOINT',IYINIT,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C
      SEGACT MLMESP
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)=MLMESP.MOTS(1)
      CALL QUEPO1(IYINIT, MELEMC, MLMOT1)
      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
      CALL LIROBJ('CHPOINT',IYFINA,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C
      CALL QUEPO1(IYFINA, MELEMC, MLMOT1)
      SEGSUP MLMOT1
      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
C
C**** Le CHPOINT de la vitesse caractéristique
C
      CALL LIROBJ('CHPOINT',IVCAR,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='SCAL'
      CALL QUEPO1(IVCAR, MELEMC, MLMOT1)
      SEGSUP MLMOT1
      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
C
C**** Le CHPOINT de la dimension de la maille
C
      CALL LIROBJ('CHPOINT',IDX,1,IRET)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT
C
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='SCAL'
      CALL QUEPO1(IDX, MELEMC, MLMOT1)
      SEGSUP MLMOT1
      IF(IERR .NE. 0)THEN
         IERR0 = IERR
 
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'CHPO6 = ???                             '
         WRITE(IOIMP,*) MOTERR
 
         GOTO 9999
      ENDIF
C
C**** EPS1
C     Critere original du model CREBCOM
C
      CALL LIRREE(EPS1,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
C**** DELTAT
C
      CALL LIRREE(DELTAT,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
C**** EPSCSI
C     Critere original du model CREBCOM
C
      CALL LIRREE(EPSCSI,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
C**** Creation d'un CHPOINT contenat l'increment d'energie
C
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='SCAL'
      TYPE = '        '
      CALL KRCHP1(TYPE, MELEMC, ICHRET, MLMOT1)
      SEGSUP MLMOT1
      IF(IERR.NE.0) GOTO 9999
C
C**** Creation d'un CHPOINT contenant la variation des densité massiques
C
      TYPE = '        '
      CALL KRCHP1(TYPE, MELEMC, ICHRYN, MLMESP)
      IF(IERR.NE.0) GOTO 9999
      SEGDES MLMESP
C
C**** Calcul
C
      CALL FLACR3(EPSCSI,EPS1,DELTAT,MELEMC,MELEFE,IRC,IYC,IYINIT,IYFINA
     $     ,IVCAR,IDX,MLRMAS,MLRH0K,MLRECO,ICHRET,ICHRYN)
      IF(IERR.NE.0)GOTO 9999
C
      SEGDES MLMESP
      SEGDES MLRECO
      SEGDES MLRECO
      SEGSUP MLRH0K
      SEGSUP MLRMAS
C
C**** Ecriture du resultat
C
      CALL ECROBJ('CHPOINT ',ICHRYN)
      IF(IERR.NE.0)GOTO 9999
      CALL ECROBJ('CHPOINT ',ICHRET)
      IF(IERR.NE.0)GOTO 9999
C
 9999 RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

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