Télécharger flacr2.eso

Retour à la liste

Numérotation des lignes :

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

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