Sources Esope | Cast3M

flamcr
C FLAMCR    SOURCE    CB215821  20/11/25    13:29:05     10792          
      SUBROUTINE FLAMCR()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  FLAMCR
C
C DESCRIPTION       :  CREBCOM: critere de combustion
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 SMELEME
      POINTEUR MELEFE.MELEME
-INC SMCHPOI
      POINTEUR MPOCSI.MPOVAL
-INC SMLMOTS
-INC SMLENTI
      INTEGER JGN, JGM
      POINTEUR MLECEN.MLENTI
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
      INTEGER IDOMA,IRET,MELEMC,ICSI,IGEOM,NCEN,NFAC,NLCF,ICEN
     &     ,ICHPO1,NGCED,NGCEG,NLCED,NLCEG,N,NC, ICOND, INEFMD
 
      REAL*8 EPS1, CSIMAX, VCSIG, VCSID, VCSI2G, VCSI2D, EPS12
     &     , CSIG
      CHARACTER*8 TYPE
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**** EPS1
C     Critere original du model CREBCOM
C
      CALL LIRREE(EPS1,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
C**** CSIMAX
C
      CALL LIRREE(CSIMAX,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
C**** ICSI = Progress Variable
C
      TYPE='CHPOINT '
      CALL  LIROBJ(TYPE,ICSI,1,IRET)
      IF(IERR.NE.0) GOTO 9999
C
      MLMOT1=0
      CALL QUEPO1(ICSI,MELEMC,MLMOT1)
      IF(IERR.NE.0) GOTO 9999
      SEGSUP MLMOT1
C
      CALL LICHT(ICSI,MPOCSI,TYPE,IGEOM)
C     SEGACT MPOCSI
      IF(IERR.NE.0) GOTO 9999
C
C**** CHPOINT qui vaut 1 si on a combustion
C             zero o contraire
      JGN=4
      JGM=1
      SEGINI MLMOT1
      MLMOT1.MOTS(1)='SCAL'
      TYPE = '        '
      CALL KRCHP1(TYPE, MELEMC, ICHPO1, MLMOT1)
C     SEGDES MLMOT1
      IF(IERR.NE.0) GOTO 9999
      CALL LICHT(ICHPO1,MPOVA1,TYPE,IGEOM)
C     SEGACT MPOVA1
      IF(IERR.NE.0) GOTO 9999
C
C**** KRIPAD pour la correspondance global/local de centre
C
      CALL KRIPAD(MELEMC,MLECEN)
      IF(IERR .NE. 0)GOTO 9999
C
C     SEGACT MLECEN
      IPT1 = MELEMC
      SEGACT IPT1
      NCEN = IPT1.NUM(/2)
      SEGDES IPT1
C
      SEGACT MELEFE
      NFAC=MELEFE.NUM(/2)
C
      DO NLCF = 1, NFAC
C
C******* NLCF  = numero local du centre de facel
C        NGCEG = numero global du centre ELT "gauche"
C        NLCEG = numero local du centre ELT "gauche"
C        NGCED = numero global du centre ELT "droite"
C        NLCED = numero local du centre ELT "droite"
C
         NGCEG = MELEFE.NUM(1,NLCF)
         NGCED = MELEFE.NUM(3,NLCF)
         NLCEG = MLECEN.LECT(NGCEG)
         NLCED = MLECEN.LECT(NGCED)
C
         VCSIG=MPOCSI.VPOCHA(NLCEG,1)
         VCSID=MPOCSI.VPOCHA(NLCED,1)
         VCSI2G=VCSIG*VCSIG
         VCSI2D=VCSID*VCSID
C
         IF(NLCEG .EQ. NLCED)THEN
C
C********** Murs
C
            MPOVA1.VPOCHA(NLCEG,1)=MPOVA1.VPOCHA(NLCEG,1) + (0.5D0 *
     &           VCSI2D)
C
         ELSE
C
            MPOVA1.VPOCHA(NLCEG,1)=MPOVA1.VPOCHA(NLCEG,1) +
     &           (VCSI2D - (0.5D0 * VCSI2G))
            MPOVA1.VPOCHA(NLCED,1)=MPOVA1.VPOCHA(NLCED,1) +
     &           (VCSI2G - (0.5D0 * VCSI2D))
C
         ENDIF
      ENDDO
C
      EPS12 = EPS1 * EPS1
      DO ICEN = 1, NCEN, 1
         VCSIG =  MPOVA1.VPOCHA(ICEN,1)
         CSIG = MPOCSI.VPOCHA(ICEN,1)
C
C******* In 2D, contribution of the ideal upper and lower cells
C
         IF(IDIM .EQ. 2) VCSIG = VCSIG + (CSIG * CSIG)
         IF((VCSIG .GT. EPS12) .AND. (CSIG .LT. CSIMAX))THEN
C
C********** Il y a combustion
C
            MPOVA1.VPOCHA(ICEN,1) = 1.0D0
         ELSE
            MPOVA1.VPOCHA(ICEN,1) = 0.0D0
         ENDIF
      ENDDO
C
      SEGDES MPOVA1
      SEGDES MPOCSI
      SEGDES MELEFE
      SEGSUP MLECEN
C
C**** Ecriture du resultat
C
      CALL ECROBJ('CHPOINT ',ICHPO1)
      IF(IERR.NE.0)GOTO 9999
C
 9999 RETURN
      END