1 : C FLAMCR SOURCE CHAT 06/08/24 21:35:58 5529 2 : SUBROUTINE FLAMCR() 3 : C************************************************************************ 4 : C 5 : C PROJET : CASTEM 2000 6 : C 7 : C NOM : FLAMCR 8 : C 9 : C DESCRIPTION : CREBCOM: critere de combustion 10 : C 11 : C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI) 12 : C 13 : C AUTEUR : A. BECCANTINI, DM2S/SFME/LTMF 14 : C 15 : C************************************************************************ 16 : C 17 : C 18 : C************************************************************************ 19 : C 20 : C HISTORIQUE (Anomalies et modifications éventuelles) 21 : C 22 : C HISTORIQUE : 23 : C 24 : C 25 : C************************************************************************ 26 : C 27 : IMPLICIT INTEGER(I-N) 28 : -INC CCOPTIO 29 : -INC SMELEME 30 : POINTEUR MELEFE.MELEME 31 : -INC SMCHPOI 32 : POINTEUR MPOCSI.MPOVAL 33 : -INC SMLMOTS 34 : -INC SMLENTI 35 : INTEGER JGN, JGM 36 : POINTEUR MLECEN.MLENTI 37 : C 38 : C**** Variables de COOPTIO 39 : C 40 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 41 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 42 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 43 : C & ,IECHO, IIMPI, IOSPI 44 : C & ,IDIM 45 : C & ,MCOORD 46 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 47 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 48 : C & ,NORINC,NORVAL,NORIND,NORVAD 49 : C & ,NUCROU, IPSAUV 50 : C 51 : C**** Les variables 52 : C 53 : INTEGER IDOMA,IRET,MELEMC,ICSI,IGEOM,NCEN,NFAC,NLCF,ICEN 54 : & ,ICHPO1,NGCED,NGCEG,NLCED,NLCEG,N,NC, ICOND, INEFMD 55 : 56 : REAL*8 EPS1, CSIMAX, VCSIG, VCSID, VCSI2G, VCSI2D, EPS12 57 : & , CSIG 58 : CHARACTER*8 TYPE 59 : C 60 : C**** Lecture de l'objet MODELE 61 : C 62 : ICOND = 1 62 : CALL QUETYP(TYPE,ICOND,IRET) 63 : 64 : IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN 65 : WRITE(6,*)' On attend un objet MMODEL' 66 : RETURN 67 : ENDIF 67 : CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET) 68 : IF(IERR.NE.0)GOTO 9999 68 : CALL LEKMOD(MMODEL,IDOMA,INEFMD) 69 : IF(IERR.NE.0)GOTO 9999 70 : C 71 : C**** CENTRE, et FACEL 72 : C 72 : CALL LEKTAB(IDOMA,'CENTRE',MELEMC) 73 : IF(IERR .NE. 0) GOTO 9999 74 : C 74 : CALL LEKTAB(IDOMA,'FACEL',MELEFE) 75 : IF(IERR .NE. 0) GOTO 9999 76 : C 77 : C**** EPS1 78 : C Critere original du model CREBCOM 79 : C 79 : CALL LIRREE(EPS1,1,IRET) 80 : IF(IERR.NE.0) GOTO 9999 81 : C 82 : C**** CSIMAX 83 : C 83 : CALL LIRREE(CSIMAX,1,IRET) 84 : IF(IERR.NE.0) GOTO 9999 85 : C 86 : C**** ICSI = Progress Variable 87 : C 88 : TYPE='CHPOINT ' 88 : CALL LIROBJ(TYPE,ICSI,1,IRET) 89 : IF(IERR.NE.0) GOTO 9999 90 : C 91 : MLMOT1=0 91 : CALL QUEPO1(ICSI,MELEMC,MLMOT1) 92 : IF(IERR.NE.0) GOTO 9999 93 : SEGSUP MLMOT1 94 : C 94 : CALL LICHT(ICSI,MPOCSI,TYPE,IGEOM) 95 : C SEGACT MPOCSI 96 : IF(IERR.NE.0) GOTO 9999 97 : C 98 : C**** CHPOINT qui vaut 1 si on a combustion 99 : C zero o contraire 100 : JGN=4 101 : JGM=1 102 : SEGINI MLMOT1 103 : MLMOT1.MOTS(1)='SCAL' 104 : TYPE = ' ' 104 : CALL KRCHP1(TYPE, MELEMC, ICHPO1, MLMOT1) 105 : C SEGDES MLMOT1 106 : IF(IERR.NE.0) GOTO 9999 106 : CALL LICHT(ICHPO1,MPOVA1,TYPE,IGEOM) 107 : C SEGACT MPOVA1 108 : IF(IERR.NE.0) GOTO 9999 109 : C 110 : C**** KRIPAD pour la correspondance global/local de centre 111 : C 111 : CALL KRIPAD(MELEMC,MLECEN) 112 : IF(IERR .NE. 0)GOTO 9999 113 : C 114 : C SEGACT MLECEN 115 : IPT1 = MELEMC 116 : SEGACT IPT1 117 : NCEN = IPT1.NUM(/2) 118 : SEGDES IPT1 119 : C 120 : SEGACT MELEFE 121 : NFAC=MELEFE.NUM(/2) 122 : C 123 : DO NLCF = 1, NFAC 124 : C 125 : C******* NLCF = numero local du centre de facel 126 : C NGCEG = numero global du centre ELT "gauche" 127 : C NLCEG = numero local du centre ELT "gauche" 128 : C NGCED = numero global du centre ELT "droite" 129 : C NLCED = numero local du centre ELT "droite" 130 : C 131 : NGCEG = MELEFE.NUM(1,NLCF) 132 : NGCED = MELEFE.NUM(3,NLCF) 133 : NLCEG = MLECEN.LECT(NGCEG) 134 : NLCED = MLECEN.LECT(NGCED) 135 : C 136 : VCSIG=MPOCSI.VPOCHA(NLCEG,1) 137 : VCSID=MPOCSI.VPOCHA(NLCED,1) 138 : VCSI2G=VCSIG*VCSIG 139 : VCSI2D=VCSID*VCSID 140 : C 141 : IF(NLCEG .EQ. NLCED)THEN 142 : C 143 : C********** Murs 144 : C 145 : MPOVA1.VPOCHA(NLCEG,1)=MPOVA1.VPOCHA(NLCEG,1) + (0.5D0 * 146 : & VCSI2D) 147 : C 148 : ELSE 149 : C 150 : MPOVA1.VPOCHA(NLCEG,1)=MPOVA1.VPOCHA(NLCEG,1) + 151 : & (VCSI2D - (0.5D0 * VCSI2G)) 152 : MPOVA1.VPOCHA(NLCED,1)=MPOVA1.VPOCHA(NLCED,1) + 153 : & (VCSI2G - (0.5D0 * VCSI2D)) 154 : C 155 : ENDIF 156 : ENDDO 157 : C 158 : EPS12 = EPS1 * EPS1 159 : DO ICEN = 1, NCEN, 1 160 : VCSIG = MPOVA1.VPOCHA(ICEN,1) 161 : CSIG = MPOCSI.VPOCHA(ICEN,1) 162 : C 163 : C******* In 2D, contribution of the ideal upper and lower cells 164 : C 165 : IF(IDIM .EQ. 2) VCSIG = VCSIG + (CSIG * CSIG) 166 : IF((VCSIG .GT. EPS12) .AND. (CSIG .LT. CSIMAX))THEN 167 : C 168 : C********** Il y a combustion 169 : C 170 : MPOVA1.VPOCHA(ICEN,1) = 1.0D0 171 : ELSE 172 : MPOVA1.VPOCHA(ICEN,1) = 0.0D0 173 : ENDIF 174 : ENDDO 175 : C 176 : SEGDES MPOVA1 177 : SEGDES MPOCSI 178 : SEGDES MELEFE 179 : SEGSUP MLECEN 180 : C 181 : C**** Ecriture du resultat 182 : C 182 : CALL ECROBJ('CHPOINT ',ICHPO1) 183 : IF(IERR.NE.0)GOTO 9999 184 : C 185 : 9999 RETURN 186 : END 187 : 188 : 189 : 190 : 191 : 192 : 193 : 194 : 195 : 196 : 197 : 198 : 199 :
© Cast3M 2003 - All rights reserved.
Disclaimer