Télécharger flacr2.eso

Retour à la liste

Numérotation des lignes :

  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
  70. CALL QUETYP(TYPE,ICOND,IRET)
  71.  
  72. IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN
  73. WRITE(6,*)' On attend un objet MMODEL'
  74. RETURN
  75. ENDIF
  76. CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET)
  77. IF(IERR.NE.0)GOTO 9999
  78. CALL LEKMOD(MMODEL,IDOMA,INEFMD)
  79. IF(IERR.NE.0)GOTO 9999
  80. C
  81. C**** CENTRE, et FACEL
  82. C
  83. CALL LEKTAB(IDOMA,'CENTRE',MELEMC)
  84. IF(IERR .NE. 0) GOTO 9999
  85. C
  86. CALL LEKTAB(IDOMA,'FACEL',MELEFE)
  87. IF(IERR .NE. 0) GOTO 9999
  88. C
  89. C**** La reaction chimique
  90. C Noms des especes qui interviennent
  91. C
  92. TYPE='LISTMOTS'
  93. CALL LIROBJ(TYPE,MLMESP,1,IRET)
  94. IF(IERR .NE. 0)GOTO 9999
  95. SEGACT MLMESP
  96. NESP=MLMESP.MOTS(/2)
  97. C
  98. C**** Les coeff. stoich.
  99. C Ils sont positifs pour les reactants
  100. C negatives pour les produits
  101. C
  102. TYPE='LISTREEL'
  103. CALL LIROBJ(TYPE,MLRECO,1,IRET)
  104. IF(IERR .NE. 0)GOTO 9999
  105. SEGACT MLRECO
  106. NESP1=MLRECO.PROG(/1)
  107. IF(NESP1 .NE. NESP)THEN
  108. MOTERR(1:40)='LMOT1 = ??? '
  109. WRITE(IOIMP,*) MOTERR
  110. MOTERR(1:40)='LREE1 = ??? '
  111. WRITE(IOIMP,*) MOTERR
  112. CALL ERREUR(21)
  113. GOTO 9999
  114. ENDIF
  115. C
  116. C**** La LISTREEL des poids molaires MLRMAS
  117. C des énergies de formation à 0K
  118. C MLRH0K
  119. C
  120. JG=NESP
  121. SEGINI MLRMAS
  122. SEGINI MLRH0K
  123. C
  124. C************************************************
  125. C**** La table des proprietés des gaz ***********
  126. C************************************************
  127. C
  128. TYPE='TABLE '
  129. CALL LIROBJ(TYPE,IPGAS,1,IRET)
  130. IF(IERR .NE. 0)GOTO 9999
  131. DO I1 = 1, NESP, 1
  132. MOT1(1) = MLMESP.MOTS(I1)
  133. C
  134. C******* CALL ACMF(...) ne marche pas parce que on a
  135. C des blanches dans nos composantes
  136. C
  137. MTYPI = 'MOT '
  138. MTYPR = ' '
  139. CALL ACCTAB(IPGAS,MTYPI,IVALI,XVALI,MOT1(1), LOGII,IRETI,
  140. & MTYPR,IVALR,XVALR,CHARR,LOGIR,IESP)
  141. C
  142. C******* En IESP a la table IPGAS.MOT1(1)
  143. C
  144. IF((IERR .NE. 0) .OR. (MTYPR .NE. 'TABLE ')) THEN
  145.  
  146. C
  147. C********** Message d'erreur standard
  148. C -301 0 %m1:40
  149. C
  150. MOTERR = ' '
  151. MOTERR(1:7) = 'TAB2 . '
  152. MOTERR(8:11) = MOT1(1)
  153. MOTERR(13:17) = '= ???'
  154. WRITE(IOIMP,*) MOTERR(1:40)
  155. C
  156. C********** Message d'erreur standard
  157. C 21 2
  158. C Données incompatibles
  159. C
  160. CALL ERREUR(21)
  161. GOTO 9999
  162. ENDIF
  163. C
  164. C******* R
  165. C
  166. MTYPI = 'MOT '
  167. MTYPR = ' '
  168. CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'R' , LOGII,IRETI,
  169. & MTYPR,IVALR, XVALR ,CHARR,LOGIR,IRETR)
  170. IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
  171.  
  172. C
  173. C********** Message d'erreur standard
  174. C -301 0 %m1:40
  175. C
  176. MOTERR = ' '
  177. MOTERR(1:7) = 'TAB2 . '
  178. MOTERR(8:11) = MOT1(1)
  179. MOTERR(13:23) = ' . R = ??? '
  180. WRITE(IOIMP,*) MOTERR(1:40)
  181. C
  182. C********** Message d'erreur standard
  183. C 21 2
  184. C Données incompatibles
  185. C
  186. CALL ERREUR(21)
  187. GOTO 9999
  188. ENDIF
  189. MLRMAS.PROG(I1)=RGAS/XVALR
  190. C
  191. C******* H0K
  192. C
  193. MTYPI = 'MOT '
  194. MTYPR = ' '
  195. CALL ACCTAB(IESP,MTYPI,IVALI,XVALI, 'H0K' , LOGII,IRETI,
  196. & MTYPR,IVALR, XVALR ,CHARR,LOGIR,IRETR)
  197. IF((IERR .NE. 0) .OR. (MTYPR .NE. 'FLOTTANT')) THEN
  198.  
  199. C
  200. C********** Message d'erreur standard
  201. C -301 0 %m1:40
  202. C
  203. MOTERR = ' '
  204. MOTERR(1:7) = 'TAB2 . '
  205. MOTERR(8:11) = MOT1(1)
  206. MOTERR(13:25) = ' . H0K = ??? '
  207. WRITE(IOIMP,*) MOTERR(1:40)
  208. C
  209. C********** Message d'erreur standard
  210. C 21 2
  211. C Données incompatibles
  212. C
  213. CALL ERREUR(21)
  214. GOTO 9999
  215. ENDIF
  216. MLRH0K.PROG(I1)=XVALR
  217. ENDDO
  218. C
  219. C**** Les CHPOINT densité
  220. C
  221. CALL LIROBJ('CHPOINT',IRC,1,IRET)
  222. IF (IERR.NE.0) GOTO 9999
  223. C
  224. C**** Control du CHPOINT
  225. C IRC ordonné selon MLECEN
  226. C
  227. JGN=4
  228. JGM=1
  229. SEGINI MLMOT1
  230. MLMOT1.MOTS(1)='SCAL'
  231. CALL QUEPO1(IRC, MELEMC, MLMOT1)
  232. SEGSUP MLMOT1
  233. IF(IERR .NE. 0)THEN
  234. IERR0 = IERR
  235.  
  236. C
  237. C******* Message d'erreur standard
  238. C -301 0 %m1:40
  239. C
  240. MOTERR(1:40) = 'CHPO1 = ??? '
  241. WRITE(IOIMP,*) MOTERR
  242.  
  243. GOTO 9999
  244. ENDIF
  245. C
  246. C**** Les CHPOINTs des fractions massiques des especes
  247. C
  248. CALL LIROBJ('CHPOINT',IYC,1,IRET)
  249. IF (IERR.NE.0) GOTO 9999
  250. C
  251. C**** Control du CHPOINT
  252. C IYC ordonné selon MELEMC et MLMESP
  253. C
  254. CALL QUEPO1(IYC, MELEMC, MLMESP)
  255. C Attention: MLMESP desactivé en sortie de QUEPO1
  256. IF(IERR .NE. 0)THEN
  257. IERR0 = IERR
  258.  
  259. C
  260. C******* Message d'erreur standard
  261. C -301 0 %m1:40
  262. C
  263. MOTERR(1:40) = 'CHPO2 = ??? '
  264. WRITE(IOIMP,*) MOTERR
  265.  
  266. GOTO 9999
  267. ENDIF
  268. C
  269. C**** Les CHPOINTs des fractions massiques initiale et finale de
  270. C l'espece en MLMESP.MOTS(1)
  271. C
  272. CALL LIROBJ('CHPOINT',IYINIT,1,IRET)
  273. IF (IERR.NE.0) GOTO 9999
  274. C
  275. C**** Control du CHPOINT
  276. C
  277. SEGACT MLMESP
  278. JGN=4
  279. JGM=1
  280. SEGINI MLMOT1
  281. MLMOT1.MOTS(1)=MLMESP.MOTS(1)
  282. CALL QUEPO1(IYINIT, MELEMC, MLMOT1)
  283. IF(IERR .NE. 0)THEN
  284. IERR0 = IERR
  285.  
  286. C
  287. C******* Message d'erreur standard
  288. C -301 0 %m1:40
  289. C
  290. MOTERR(1:40) = 'CHPO3 = ??? '
  291. WRITE(IOIMP,*) MOTERR
  292.  
  293. GOTO 9999
  294. ENDIF
  295. C
  296. CALL LIROBJ('CHPOINT',IYFINA,1,IRET)
  297. IF (IERR.NE.0) GOTO 9999
  298. C
  299. C**** Control du CHPOINT
  300. C
  301. CALL QUEPO1(IYFINA, 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) = 'CHPO4 = ??? '
  311. WRITE(IOIMP,*) MOTERR
  312.  
  313. GOTO 9999
  314. ENDIF
  315. C
  316. C**** Le CHPOINT de la vitesse caractéristique
  317. C
  318. CALL LIROBJ('CHPOINT',IVCAR,1,IRET)
  319. IF (IERR.NE.0) GOTO 9999
  320. C
  321. C**** Control du CHPOINT
  322. C
  323. JGN=4
  324. JGM=1
  325. SEGINI MLMOT1
  326. MLMOT1.MOTS(1)='SCAL'
  327. CALL QUEPO1(IVCAR, MELEMC, MLMOT1)
  328. SEGSUP MLMOT1
  329. IF(IERR .NE. 0)THEN
  330. IERR0 = IERR
  331.  
  332. C
  333. C******* Message d'erreur standard
  334. C -301 0 %m1:40
  335. C
  336. MOTERR(1:40) = 'CHPO5 = ??? '
  337. WRITE(IOIMP,*) MOTERR
  338.  
  339. GOTO 9999
  340. ENDIF
  341. C
  342. C**** Le CHPOINT de la dimension de la maille
  343. C
  344. CALL LIROBJ('CHPOINT',IDX,1,IRET)
  345. IF (IERR.NE.0) GOTO 9999
  346. C
  347. C**** Control du CHPOINT
  348. C
  349. JGN=4
  350. JGM=1
  351. SEGINI MLMOT1
  352. MLMOT1.MOTS(1)='SCAL'
  353. CALL QUEPO1(IDX, MELEMC, MLMOT1)
  354. SEGSUP MLMOT1
  355. IF(IERR .NE. 0)THEN
  356. IERR0 = IERR
  357.  
  358. C
  359. C******* Message d'erreur standard
  360. C -301 0 %m1:40
  361. C
  362. MOTERR(1:40) = 'CHPO6 = ??? '
  363. WRITE(IOIMP,*) MOTERR
  364.  
  365. GOTO 9999
  366. ENDIF
  367. C
  368. C**** EPS1
  369. C Critere original du model CREBCOM
  370. C
  371. CALL LIRREE(EPS1,1,IRET)
  372. IF(IERR.NE.0) GOTO 9999
  373. C
  374. C**** DELTAT
  375. C
  376. CALL LIRREE(DELTAT,1,IRET)
  377. IF(IERR.NE.0) GOTO 9999
  378. C
  379. C**** EPSCSI
  380. C Critere original du model CREBCOM
  381. C
  382. CALL LIRREE(EPSCSI,1,IRET)
  383. IF(IERR.NE.0) GOTO 9999
  384. C
  385. C**** Creation d'un CHPOINT contenat l'increment d'energie
  386. C
  387. JGN=4
  388. JGM=1
  389. SEGINI MLMOT1
  390. MLMOT1.MOTS(1)='SCAL'
  391. TYPE = ' '
  392. CALL KRCHP1(TYPE, MELEMC, ICHRET, MLMOT1)
  393. SEGSUP MLMOT1
  394. IF(IERR.NE.0) GOTO 9999
  395. C
  396. C**** Creation d'un CHPOINT contenant la variation des densité massiques
  397. C
  398. TYPE = ' '
  399. CALL KRCHP1(TYPE, MELEMC, ICHRYN, MLMESP)
  400. IF(IERR.NE.0) GOTO 9999
  401. SEGDES MLMESP
  402. C
  403. C**** Calcul
  404. C
  405. CALL FLACR3(EPSCSI,EPS1,DELTAT,MELEMC,MELEFE,IRC,IYC,IYINIT,IYFINA
  406. $ ,IVCAR,IDX,MLRMAS,MLRH0K,MLRECO,ICHRET,ICHRYN)
  407. IF(IERR.NE.0)GOTO 9999
  408. C
  409. SEGDES MLMESP
  410. SEGDES MLRECO
  411. SEGDES MLRECO
  412. SEGSUP MLRH0K
  413. SEGSUP MLRMAS
  414. C
  415. C**** Ecriture du resultat
  416. C
  417. CALL ECROBJ('CHPOINT ',ICHRYN)
  418. IF(IERR.NE.0)GOTO 9999
  419. CALL ECROBJ('CHPOINT ',ICHRET)
  420. IF(IERR.NE.0)GOTO 9999
  421. C
  422. 9999 RETURN
  423. END
  424.  
  425.  
  426.  
  427.  
  428.  
  429.  
  430.  
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  

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