Télécharger chinps.eso

Retour à la liste

Numérotation des lignes :

  1. C CHINPS SOURCE CHAT 05/01/12 21:57:51 5004
  2. SUBROUTINE CHINPS(IDSCHI,LXMX,IOCHI1,IOCHI2)
  3. C
  4. C
  5. C=======================================================================
  6. C
  7. C
  8. C !!!ATTENTION! POUR LE CHOIX DES MINERAUX A CONSIDERER CF CHINP
  9. C ------------------------------------------------------------------
  10. C ATTENTION|
  11. C SP DE LECTURE CORRESPONDANT A LA BASE DE DONNEES DE STRASBOURG
  12. C SOUS FORMAT MINEQL
  13. C et aux bases issues de CHESS utilisables par CASTEM
  14. C
  15. C
  16. C======================================================================
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8(A-H,O-Z)
  19. -INC SMLENTI
  20. POINTEUR MLXMX.MLENTI
  21. -INC CCOPTIO
  22. CHARACTER*5 MOCLE
  23. CHARACTER*32 NAMLXM
  24. LOGICAL LIBRE
  25. SEGMENT IDSCHI
  26. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  27. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  28. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  29. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  30. ENDSEGMENT
  31. C
  32. SEGMENT ITRAV
  33. REAL*8 CIAT(NXCMP)
  34. INTEGER IDT(NXCMP)
  35. ENDSEGMENT
  36. C
  37. SEGMENT IZCOMP
  38. CHARACTER*32 NAM(NXD)
  39. INTEGER ION(NXD),IADXT(NXD)
  40. ENDSEGMENT
  41.  
  42. NXDIM=IDX(/1)
  43. NYDIM=IDY(/1)
  44. NZDIM=IDZ(/1)
  45. NPDIM=IDP(/1)
  46. LIBRE=.TRUE.
  47. READ(IOCHI1,590)NXD,NAMLXM
  48. IF(NAMLXM(1:10).NE.'COMPOSANTS')THEN
  49. NXD=200
  50. BACKSPACE IOCHI1
  51. LIBRE=.FALSE.
  52. ENDIF
  53. NNN=NXDIM
  54. NOUVI=0
  55. SEGINI IZCOMP
  56.  
  57. C INITIALIZE ADDRESS
  58. DO 20 J=1,NXD
  59. IADXT(J)=0
  60. NAM(J)=' '
  61. 20 CONTINUE
  62. C
  63. CBRUNO
  64. IF(LIBRE)THEN
  65. READ(IOCHI1,580) (NAM(J),J=1,NXD)
  66. ELSE
  67. READ(IOCHI1,520) (NAM(J)(1:12),J=1,NXD)
  68. ENDIF
  69. READ(IOCHI1,530) (ION(J),J=1,NXD)
  70. C
  71. C INITIALIZE NN
  72. C
  73. N3=0
  74. DO 100 L=1,6
  75. NN(L)=0
  76. 100 CONTINUE
  77. C
  78. C
  79. C INITIALIZE A
  80.  
  81. DO 110 J=1,NXDIM
  82. DO 111 I=1,NYDIM
  83. AA(I,J)=0.D0
  84. 111 CONTINUE
  85. 110 CONTINUE
  86.  
  87.  
  88. C INPUT BASIS IN A MATRIX
  89.  
  90. DO 200 I=1,NNN
  91. IDXT=IDX(I)
  92. IF(IDXT.GT.NXD)THEN
  93. INTERR(1)=IDXT
  94. CALL ERREUR(781)
  95. GO TO 500
  96. ENDIF
  97. CBRUNO
  98. NAME(I)=NAM(IDXT)
  99. NAMESP(I)=NAM(IDXT)
  100. IONZ(I)=ION(IDXT)
  101. IADXT(IDXT)=I
  102. IDY(I)=IDX(I)
  103. AA(I,I)=1.D0
  104. GK(I)=0.D0
  105. 200 CONTINUE
  106.  
  107. NN(1)=NNN
  108.  
  109. C ***************** LECTURE DES DONNEES THERMODYNAMIQUES
  110. C
  111. NXCMP=8
  112. SEGINI ITRAV
  113. I=NN(1)
  114. DO 400 L=2,6
  115. I0=I
  116. READ(IOCHI2,540) IN,MOCLE,NBCMP
  117. IF(MOCLE.EQ.'LIBRE')THEN
  118. LIBRE=.TRUE.
  119. NXCMP=NBCMP
  120. SEGADJ ITRAV
  121. ELSE
  122. LIBRE=.FALSE.
  123. NBCMP=8
  124. ENDIF
  125. IF(IN.EQ.0) GO TO 400
  126. DO 300 II=1,IN
  127. IF(LIBRE)THEN
  128. READ(IOCHI2,550) IDYT,GKT,(IDT(J),CIAT(J),J=1,4)
  129. J1=5
  130. IF(NBCMP.GT.8)THEN
  131. NBENR=(NBCMP-8)/4
  132. DO 40 JJ=1,NBENR
  133. J2=J1+3
  134. READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,J2)
  135. J1=J1+4
  136. 40 CONTINUE
  137. ENDIF
  138. READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,NBCMP),
  139. * LLXM,NAMLXM
  140. C WRITE(6,*) IDYT,GKT,(IDT(J),CIAT(J),J=1,NBCMP),
  141. C * LLXM,NAMLXM
  142. ELSE
  143. READ(IOCHI2,510) IDYT,GKT,(IDT(J),CIAT(J),J=1,8),
  144. * LLXM,NAMLXM
  145. ENDIF
  146.  
  147. DO 310 J=1,8
  148. JTEST=IDT(J)
  149. IF(JTEST.EQ.0) GO TO 310
  150. IF(IADXT(JTEST).EQ.0) GO TO 300
  151. 310 CONTINUE
  152.  
  153. I=I+1
  154. IF (I.GT.NYDIM)THEN
  155. MOTERR(1:8)=' CHMMX '
  156. MOTERR(9:16)='SUITENTI'
  157. CALL ERREUR(787)
  158. RETURN
  159. ENDIF
  160. IDY(I)=IDYT
  161. GK(I)=GKT
  162. NAMESP(I)=NAMLXM
  163. DO 320 J=1,8
  164. JTEST=IDT(J)
  165. IF (IDT(J).EQ.90) N3=N3+1
  166. IF(JTEST.EQ.0) GO TO 320
  167. IADTJT=IADXT(JTEST)
  168. AA(I,IADTJT)=CIAT(J)
  169. 320 CONTINUE
  170. 300 CONTINUE
  171.  
  172.  
  173. *-----------------***------MONI------***-------------------------------
  174. * CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE
  175. * EN COMPTE; AVEC MINEQL IL EXISTE UNE FACON BIEN PLUS SIMPLE ET
  176. * AUSSI EFFICACE :
  177. * METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5
  178. * (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION),
  179. * EN TYPE 6 :
  180. * NN(6)=NN(5)+NN(6)
  181. * NN(5)=0
  182. * PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS :
  183. * EX:
  184. * I5=5
  185. * I6=6
  186. * CALL EXTYP(02231,I6,I5)
  187. **********************************************************************
  188.  
  189. NBT5=0
  190. IF (L.EQ.5) THEN
  191. IF(LXMX.EQ.0) GOTO 270
  192. MLXMX=LXMX
  193. SEGACT MLXMX
  194. NMXCH=MLXMX.LECT(/1)
  195.  
  196. CPATBOS---------------------------------------------
  197. C MISE EN IDP DES MINERAUX CHOISIS PAR L UTILISATEUR
  198. NPDIM=NMXCH
  199. SEGADJ IDSCHI
  200. CALL RSETI(IDP,MLXMX.LECT,NPDIM)
  201. IN5=I
  202. C -------
  203. *C RECHERCHE DES MINERAUX NON PRIS EN COMPTE
  204. C ----
  205. III=I
  206. DO 266 ICHOI=I0+1,III
  207. DO 267 NM0=1,NMXCH
  208. IF (IDY(ICHOI).EQ.MLXMX.LECT(NM0)) THEN
  209. NOUVI=NOUVI+1
  210. IDY(I0+NOUVI)=IDY(ICHOI)
  211. GK(I0+NOUVI)=GK(ICHOI)
  212. NAMESP(I0+NOUVI)=NAMESP(ICHOI)
  213. DO 220 JK=1,NNN
  214. AA(I0+NOUVI,JK)=AA(ICHOI,JK)
  215. 220 CONTINUE
  216. GOTO 265
  217. ENDIF
  218. 267 CONTINUE
  219.  
  220. IDY(ICHOI)=0
  221. GK(ICHOI)=0.D0
  222. NAMESP(ICHOI)=' '
  223. DO 210 JK=1,NNN
  224. AA(ICHOI,JK)=0.D0
  225. 210 CONTINUE
  226.  
  227. I=I-1
  228. 265 CONTINUE
  229. 266 CONTINUE
  230.  
  231.  
  232. DO 275 LIK = I0+NMXCH+1,IN5
  233. IDY(LIK)=0
  234. DO 274 JIK=1,NNN
  235. AA(LIK,JIK)=0.D0
  236. 274 CONTINUE
  237. 275 CONTINUE
  238. *
  239. ENDIF
  240. *
  241. 270 CONTINUE
  242.  
  243.  
  244. NN(L)=I-I0
  245. 400 CONTINUE
  246.  
  247. C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0
  248. IF(LXMX.NE.0)THEN
  249. SEGDES MLXMX
  250. ELSE
  251. NN123=NN(1)+NN(2)+NN(3)+1
  252. NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)
  253. DO 600 N=NN123,NN45
  254. NPDIM=NPDIM+1
  255. SEGADJ IDSCHI
  256. IDP(NPDIM)=IDY(N)
  257. 600 CONTINUE
  258. ENDIF
  259.  
  260. CMONI*************LE 1 MARS 91****************************************
  261. IF (I.LT.NYDIM) THEN
  262. NYDIM=I
  263. SEGADJ IDSCHI
  264. ENDIF
  265. SEGSUP IZCOMP
  266. SEGSUP ITRAV
  267. CMONI*****************************************************************
  268. 510 FORMAT (I5,F9.3,4(I4,1F6.2),/,14X,4(I4,1F6.2),T57,I1,1X,A32)
  269. C 520 FORMAT((7X,A10,3(8X,A10)))
  270. C 520 FORMAT (4(8X,A8,2X))
  271. 520 FORMAT(2X,4(6X,A12))
  272. 540 FORMAT (I5,2X,A5,I5)
  273. *
  274. 530 FORMAT (40I2)
  275. 550 FORMAT (I5,F10.8,4(I5,1X,1F6.4))
  276. 560 FORMAT (15X,4(I5,1X,1F6.4),T66,I1,1X,A22)
  277. 570 FORMAT (I5,3X,A12)
  278. 580 FORMAT (8X,A32)
  279. 590 FORMAT (I8,A32)
  280.  
  281. C*****************REMISE EN TETE DES FICHIERS ****************
  282. 500 CONTINUE
  283. C REWIND(UNIT=IOCHI2)
  284. C CLOSE(UNIT=IOCHI2)
  285. C REWIND(UNIT=IOCHI1)
  286. C CLOSE(UNIT=IOCHI1)
  287. C*******************************************************************
  288. C WRITE(6,*) 'A LA SORTIE DE CHINPS , J= ',J
  289.  
  290. RETURN
  291. END
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  

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