1 : C FLACR2 SOURCE CHAT 06/08/24 21:35:52 5529 2 : SUBROUTINE FLACR2() 3 : C************************************************************************ 4 : C 5 : C PROJET : CASTEM 2000 6 : C 7 : C NOM : FLACR2 8 : C 9 : C DESCRIPTION : CREBCOM: modele non-homogene 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 SMLMOTS 30 : POINTEUR MLMESP.MLMOTS 31 : -INC SMLREEL 32 : POINTEUR MLRECO.MLREEL, MLRMAS.MLREEL, MLRH0K.MLREEL 33 : C 34 : INTEGER JGN, JGM, JG 35 : C 36 : C**** Variables de COOPTIO 37 : C 38 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 39 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 40 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 41 : C & ,IECHO, IIMPI, IOSPI 42 : C & ,IDIM 43 : C & ,MCOORD 44 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 45 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 46 : C & ,NORINC,NORVAL,NORIND,NORVAD 47 : C & ,NUCROU, IPSAUV, ICOND, INEFMD, IFICLE, IPREFI 48 : C 49 : C**** Les variables 50 : C 51 : INTEGER IDOMA,IRET,MELEMC,MELEFE,IPGAS,IESP,NESP,NESP1 52 : & ,IRC,IYC,IYINIT,IYFINA,IVCAR,ICHRET,ICHRYN,IERR0,I1 53 : & ,IDX,MMODEL 54 : 55 : REAL*8 RGAS, EPS1, DELTAT, EPSCSI 56 : PARAMETER(RGAS=8.31441D0) 57 : CHARACTER*8 TYPE 58 : CHARACTER*4 MOT1(1) 59 : C 60 : C**** Variables en ACCTAB 61 : C 62 : INTEGER IVALI, IRETI,IVALR, IRETR 63 : REAL*8 XVALI, XVALR 64 : LOGICAL LOGII, LOGIR 65 : CHARACTER*(8) CHARR,MTYPI,MTYPR 66 : C 67 : C**** Lecture de l'objet MODELE 68 : C 69 : ICOND = 1 69 : CALL QUETYP(TYPE,ICOND,IRET) 70 : 71 : IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN 72 : WRITE(6,*)' On attend un objet MMODEL' 73 : RETURN 74 : ENDIF 74 : CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET) 75 : IF(IERR.NE.0)GOTO 9999 75 : CALL LEKMOD(MMODEL,IDOMA,INEFMD) 76 : IF(IERR.NE.0)GOTO 9999 77 : C 78 : C**** CENTRE, et FACEL 79 : C 79 : CALL LEKTAB(IDOMA,'CENTRE',MELEMC) 80 : IF(IERR .NE. 0) GOTO 9999 81 : C 81 : CALL LEKTAB(IDOMA,'FACEL',MELEFE) 82 : IF(IERR .NE. 0) GOTO 9999 83 : C 84 : C**** La reaction chimique 85 : C Noms des especes qui interviennent 86 : C 87 : TYPE='LISTMOTS' 87 : CALL LIROBJ(TYPE,MLMESP,1,IRET) 88 : IF(IERR .NE. 0)GOTO 9999 89 : SEGACT MLMESP 90 : NESP=MLMESP.MOTS(/2) 91 : C 92 : C**** Les coeff. stoich. 93 : C Ils sont positifs pour les reactants 94 : C negatives pour les produits 95 : C 96 : TYPE='LISTREEL' 96 : CALL LIROBJ(TYPE,MLRECO,1,IRET) 97 : IF(IERR .NE. 0)GOTO 9999 98 : SEGACT MLRECO 99 : NESP1=MLRECO.PROG(/1) 100 : IF(NESP1 .NE. NESP)THEN 101 : MOTERR(1:40)='LMOT1 = ??? ' 102 : WRITE(IOIMP,*) MOTERR 103 : MOTERR(1:40)='LREE1 = ??? ' 104 : WRITE(IOIMP,*) MOTERR 104 : CALL ERREUR(21) 105 : GOTO 9999 106 : ENDIF 107 : C 108 : C**** La LISTREEL des poids molaires MLRMAS 109 : C des énergies de formation à 0K 110 : C MLRH0K 111 : C 112 : JG=NESP 113 : SEGINI MLRMAS 114 : SEGINI MLRH0K 115 : C 116 : C************************************************ 117 : C**** La table des proprietés des gaz *********** 118 : C************************************************ 119 : C 120 : TYPE='TABLE ' 120 : CALL LIROBJ(TYPE,IPGAS,1,IRET) 121 : IF(IERR .NE. 0)GOTO 9999 122 : DO I1 = 1, NESP, 1 123 : MOT1(1) = MLMESP.MOTS(I1) 124 : C 124 : C******* CALL ACMF(...) ne marche pas parce que on a 125 : C des blanches dans nos composantes 126 : C 127 : MTYPI = 'MOT ' 128 : MTYPR = ' ' 128 : CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,MOT1(1), LOGII,IRETI, 129 : & MTYPR,IVALR,XVALR,CHARR,LOGIR,IESP) 130 : C 131 : C******* En IESP a la table IPGAS.MOT1(1) 132 : C 133 : IF((IERR .NE. 0) .OR. (MTYPR .NE. 'TABLE ')) THEN 134 : 135 : C 136 : C********** Message d'erreur standard 137 : C -301 0 %m1:40 138 : C 139 : MOTERR = ' ' 140 : MOTERR(1:7) = 'TAB2 . ' 141 : MOTERR(8:11) = MOT1(1) 142 : MOTERR(13:17) = '= ???' 143 : WRITE(IOIMP,*) MOTERR(1:40) 144 : C 145 : C********** Message d'erreur standard 146 : C 21 2 147 : C Données incompatibles 148 : C 148 : CALL ERREUR(21) 149 : GOTO 9999 150 : ENDIF 151 : C 152 : C******* R 153 : C 154 : MTYPI = 'MOT ' 155 : MTYPR = ' ' 155 : CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'R' , LOGII,IRETI, 156 : & MTYPR,IVALR, XVALR ,CHARR,LOGIR,IRETR) 157 : IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN 158 : 159 : C 160 : C********** Message d'erreur standard 161 : C -301 0 %m1:40 162 : C 163 : MOTERR = ' ' 164 : MOTERR(1:7) = 'TAB2 . ' 165 : MOTERR(8:11) = MOT1(1) 166 : MOTERR(13:23) = ' . R = ??? ' 167 : WRITE(IOIMP,*) MOTERR(1:40) 168 : C 169 : C********** Message d'erreur standard 170 : C 21 2 171 : C Données incompatibles 172 : C 172 : CALL ERREUR(21) 173 : GOTO 9999 174 : ENDIF 175 : MLRMAS.PROG(I1)=RGAS/XVALR 176 : C 177 : C******* H0K 178 : C 179 : MTYPI = 'MOT ' 180 : MTYPR = ' ' 180 : CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'H0K' , LOGII,IRETI, 181 : & MTYPR,IVALR, XVALR ,CHARR,LOGIR,IRETR) 182 : IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN 183 : 184 : C 185 : C********** Message d'erreur standard 186 : C -301 0 %m1:40 187 : C 188 : MOTERR = ' ' 189 : MOTERR(1:7) = 'TAB2 . ' 190 : MOTERR(8:11) = MOT1(1) 191 : MOTERR(13:25) = ' . H0K = ??? ' 192 : WRITE(IOIMP,*) MOTERR(1:40) 193 : C 194 : C********** Message d'erreur standard 195 : C 21 2 196 : C Données incompatibles 197 : C 197 : CALL ERREUR(21) 198 : GOTO 9999 199 : ENDIF 200 : MLRH0K.PROG(I1)=XVALR 201 : ENDDO 202 : C 203 : C**** Les CHPOINT densité 204 : C 204 : CALL LIROBJ('CHPOINT',IRC,1,IRET) 205 : IF (IERR.NE.0) GOTO 9999 206 : C 207 : C**** Control du CHPOINT 208 : C IRC ordonné selon MLECEN 209 : C 210 : JGN=4 211 : JGM=1 212 : SEGINI MLMOT1 213 : MLMOT1.MOTS(1)='SCAL' 213 : CALL QUEPO1(IRC, MELEMC, MLMOT1) 214 : SEGSUP MLMOT1 215 : IF(IERR .NE. 0)THEN 216 : IERR0 = IERR 217 : 218 : C 219 : C******* Message d'erreur standard 220 : C -301 0 %m1:40 221 : C 222 : MOTERR(1:40) = 'CHPO1 = ??? ' 223 : WRITE(IOIMP,*) MOTERR 224 : 225 : GOTO 9999 226 : ENDIF 227 : C 228 : C**** Les CHPOINTs des fractions massiques des especes 229 : C 229 : CALL LIROBJ('CHPOINT',IYC,1,IRET) 230 : IF (IERR.NE.0) GOTO 9999 231 : C 232 : C**** Control du CHPOINT 233 : C IYC ordonné selon MELEMC et MLMESP 234 : C 234 : CALL QUEPO1(IYC, MELEMC, MLMESP) 235 : C Attention: MLMESP desactivé en sortie de QUEPO1 236 : IF(IERR .NE. 0)THEN 237 : IERR0 = IERR 238 : 239 : C 240 : C******* Message d'erreur standard 241 : C -301 0 %m1:40 242 : C 243 : MOTERR(1:40) = 'CHPO2 = ??? ' 244 : WRITE(IOIMP,*) MOTERR 245 : 246 : GOTO 9999 247 : ENDIF 248 : C 249 : C**** Les CHPOINTs des fractions massiques initiale et finale de 250 : C l'espece en MLMESP.MOTS(1) 251 : C 251 : CALL LIROBJ('CHPOINT',IYINIT,1,IRET) 252 : IF (IERR.NE.0) GOTO 9999 253 : C 254 : C**** Control du CHPOINT 255 : C 256 : SEGACT MLMESP 257 : JGN=4 258 : JGM=1 259 : SEGINI MLMOT1 260 : MLMOT1.MOTS(1)=MLMESP.MOTS(1) 260 : CALL QUEPO1(IYINIT, MELEMC, MLMOT1) 261 : IF(IERR .NE. 0)THEN 262 : IERR0 = IERR 263 : 264 : C 265 : C******* Message d'erreur standard 266 : C -301 0 %m1:40 267 : C 268 : MOTERR(1:40) = 'CHPO3 = ??? ' 269 : WRITE(IOIMP,*) MOTERR 270 : 271 : GOTO 9999 272 : ENDIF 273 : C 273 : CALL LIROBJ('CHPOINT',IYFINA,1,IRET) 274 : IF (IERR.NE.0) GOTO 9999 275 : C 276 : C**** Control du CHPOINT 277 : C 277 : CALL QUEPO1(IYFINA, MELEMC, MLMOT1) 278 : SEGSUP MLMOT1 279 : IF(IERR .NE. 0)THEN 280 : IERR0 = IERR 281 : 282 : C 283 : C******* Message d'erreur standard 284 : C -301 0 %m1:40 285 : C 286 : MOTERR(1:40) = 'CHPO4 = ??? ' 287 : WRITE(IOIMP,*) MOTERR 288 : 289 : GOTO 9999 290 : ENDIF 291 : C 292 : C**** Le CHPOINT de la vitesse caractéristique 293 : C 293 : CALL LIROBJ('CHPOINT',IVCAR,1,IRET) 294 : IF (IERR.NE.0) GOTO 9999 295 : C 296 : C**** Control du CHPOINT 297 : C 298 : JGN=4 299 : JGM=1 300 : SEGINI MLMOT1 301 : MLMOT1.MOTS(1)='SCAL' 301 : CALL QUEPO1(IVCAR, MELEMC, MLMOT1) 302 : SEGSUP MLMOT1 303 : IF(IERR .NE. 0)THEN 304 : IERR0 = IERR 305 : 306 : C 307 : C******* Message d'erreur standard 308 : C -301 0 %m1:40 309 : C 310 : MOTERR(1:40) = 'CHPO5 = ??? ' 311 : WRITE(IOIMP,*) MOTERR 312 : 313 : GOTO 9999 314 : ENDIF 315 : C 316 : C**** Le CHPOINT de la dimension de la maille 317 : C 317 : CALL LIROBJ('CHPOINT',IDX,1,IRET) 318 : IF (IERR.NE.0) GOTO 9999 319 : C 320 : C**** Control du CHPOINT 321 : C 322 : JGN=4 323 : JGM=1 324 : SEGINI MLMOT1 325 : MLMOT1.MOTS(1)='SCAL' 325 : CALL QUEPO1(IDX, MELEMC, MLMOT1) 326 : SEGSUP MLMOT1 327 : IF(IERR .NE. 0)THEN 328 : IERR0 = IERR 329 : 330 : C 331 : C******* Message d'erreur standard 332 : C -301 0 %m1:40 333 : C 334 : MOTERR(1:40) = 'CHPO6 = ??? ' 335 : WRITE(IOIMP,*) MOTERR 336 : 337 : GOTO 9999 338 : ENDIF 339 : C 340 : C**** EPS1 341 : C Critere original du model CREBCOM 342 : C 342 : CALL LIRREE(EPS1,1,IRET) 343 : IF(IERR.NE.0) GOTO 9999 344 : C 345 : C**** DELTAT 346 : C 346 : CALL LIRREE(DELTAT,1,IRET) 347 : IF(IERR.NE.0) GOTO 9999 348 : C 349 : C**** EPSCSI 350 : C Critere original du model CREBCOM 351 : C 351 : CALL LIRREE(EPSCSI,1,IRET) 352 : IF(IERR.NE.0) GOTO 9999 353 : C 354 : C**** Creation d'un CHPOINT contenat l'increment d'energie 355 : C 356 : JGN=4 357 : JGM=1 358 : SEGINI MLMOT1 359 : MLMOT1.MOTS(1)='SCAL' 360 : TYPE = ' ' 360 : CALL KRCHP1(TYPE, MELEMC, ICHRET, MLMOT1) 361 : SEGSUP MLMOT1 362 : IF(IERR.NE.0) GOTO 9999 363 : C 364 : C**** Creation d'un CHPOINT contenant la variation des densité massiques 365 : C 366 : TYPE = ' ' 366 : CALL KRCHP1(TYPE, MELEMC, ICHRYN, MLMESP) 367 : IF(IERR.NE.0) GOTO 9999 368 : SEGDES MLMESP 369 : C 370 : C**** Calcul 371 : C 371 : CALL FLACR3(EPSCSI,EPS1,DELTAT,MELEMC,MELEFE,IRC,IYC,IYINIT,IYFINA 372 : $ ,IVCAR,IDX,MLRMAS,MLRH0K,MLRECO,ICHRET,ICHRYN) 373 : IF(IERR.NE.0)GOTO 9999 374 : C 375 : SEGDES MLMESP 376 : SEGDES MLRECO 377 : SEGDES MLRECO 378 : SEGSUP MLRH0K 379 : SEGSUP MLRMAS 380 : C 381 : C**** Ecriture du resultat 382 : C 382 : CALL ECROBJ('CHPOINT ',ICHRYN) 383 : IF(IERR.NE.0)GOTO 9999 383 : CALL ECROBJ('CHPOINT ',ICHRET) 384 : IF(IERR.NE.0)GOTO 9999 385 : C 386 : 9999 RETURN 387 : END 388 : 389 : 390 : 391 : 392 : 393 : 394 : 395 : 396 : 397 : 398 : 399 : 400 : 401 : 402 :
© Cast3M 2003 - All rights reserved.
Disclaimer