Télécharger chmsl4.eso

Retour à la liste

Numérotation des lignes :

  1. C CHMSL4 SOURCE CHAT 05/01/12 22:00:00 5004
  2.  
  3. SUBROUTINE CHMSL4(IDSCHI,SP2,IZVBID,ICTL,IEM)
  4. C ISSU DE TRIOEF (TRSOL4 ET TREXCO)
  5. C-----------------------------------------------------------------------
  6. C DYNAMIC SELECTION OF COMPONENT TO BE SUBSTITUTED
  7. C CRITERION : IN EACH STEP, ELIMINATE COMPONENT WHOSE MAXIMUM
  8. C ABSOLUTE MASS BALANCE CONTRIBUTION IS A MINIMUM. IF TWO COM-
  9. C PONENTS ARE EQUIVALENT, TAKE THE ONE WITH HIGHER LOCAL INDEX.
  10. C-----------------------------------------------------------------------
  11. C FEBRUARY 13, 1983 M. SCHWEINGRUBER / EIR
  12. C MODIFIED MAY 6, 1983 M. SCHWEINGRUBER / EIR
  13. C-----------------------------------------------------------------------
  14. C ICTL - CONTROL OF V-VECTOR BUILD-UP
  15. C 1 : C(I) UNKNOWN FOR DISSOLVED SPECIES
  16. C 2 : GOOD C(I) GUESSES AVAILABLE FOR DISS. SPECIES
  17. C---------------------------------------------------------------------
  18. C
  19. C VBID ET JEX DIMENSION NXDIM (remplace 60)
  20. C POUR L'INSTANT ON NE FAIT PAS UN SEGINI CAR LE SP
  21. C EST DANS DES BOUCLES
  22. C----------------------------------------------------------------------
  23. C
  24. IMPLICIT INTEGER(I-N)
  25. IMPLICIT REAL*8 (A-H,O-Z)
  26. -INC CCOPTIO
  27. C
  28. SEGMENT IDSCHI
  29. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  30. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  31. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  32. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  33. ENDSEGMENT
  34. SEGMENT SP2
  35. REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM)
  36. REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM)
  37. REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM)
  38. ENDSEGMENT
  39. SEGMENT IZVBID
  40. INTEGER JEX(NXDIM)
  41. REAL*8 VBID(NXDIM)
  42. ENDSEGMENT
  43. CHARACTER*32 NAMINT
  44. C DIMENSION JEX(60),VBID(60)
  45. C
  46. NXDIM=IDX(/1)
  47. NYDIM=IDY(/1)
  48. NZDIM=IDZ(/1)
  49. NPDIM=IDP(/1)
  50.  
  51. *********************************************************************
  52. C PRISE EN COMPTE DES SOLUTIONS SOLIDES : METHODE 1
  53. N4S=0
  54. * IF(NZDIM.NE.0)THEN
  55. * I3S=NN(1)+NN(2)+NN(3)+1
  56. * I4S=NN(1)+NN(2)+NN(3)+NN(4)
  57. * DO 13 I7S=I3S,I4S
  58. * IDY7=IDY(I7S)
  59. * CALL CHIADY(IDZ,NZDIM,IDY7,ID7)
  60. * IF(ID7.NE.0)THEN
  61. * N4S=N4S+1
  62. * CALL CHMREX(IDSCHI,LGKMOD,LGKTMP,IDY7,4,5)
  63. * CALL CHMREX(IDSCHI,LGKMOD,LGKTMP,IDY7,5,4)
  64. * ENDIF
  65. * 13 CONTINUE
  66. * ENDIF
  67. *********************************************************************
  68.  
  69. LL=NN(3)+NN(4)-N4S
  70. IF (LL.EQ.0) RETURN
  71. I0=LL+NN(1)+NN(2)+1
  72. J0=NXDIM+1
  73. C--------INITIALISATION V-VECTOR
  74. IF (ICTL.GT.1) GOTO 51
  75. VV0=1.D-7
  76. DO 10 J=1,NXDIM
  77. VV=ABS(TOT(J))
  78. IF (IDX(J).EQ.50) VV=DMAX1(VV,VV0)
  79. VBID(J)=VV
  80. 10 CONTINUE
  81. GOTO 52
  82. 51 CONTINUE
  83. L1=NN(1)+NN(2)
  84. DO 20 J=1,NXDIM
  85. VBID(J)=0.D0
  86. DO 21 I=1,L1
  87. VV=ABS(AA(I,J)*CC(I))
  88. VBID(J)=DMAX1(VBID(J),VV)
  89. 21 CONTINUE
  90. 20 CONTINUE
  91. 52 CONTINUE
  92. C.......DYNAMIC SELECTION OF JEXC
  93. DO 601 L=1,LL
  94. I0=I0-1
  95. J0=J0-1
  96. NEX=0
  97.  
  98. ***********************************************************************
  99. C PRISE EN COMPTE DES SOLUTIONS SOLIDES : METHODE 1
  100. * IF(NZDIM.NE.0)THEN
  101. * IDY0=IDY(I0)
  102. * CALL CHIADY(IDZ,NZDIM,IDY0,ID0)
  103. * IF(ID0.NE.0)THEN
  104. * write(6,*)'chmsl4 idz(id0)',IDZ(ID0),'idx(j0)',IDX(J0)
  105. * J0=J0+1
  106. * GOTO 601
  107. * ENDIF
  108. * ENDIF
  109. ************************************************************************
  110.  
  111. C....... PRELIMINARY CHECKS
  112. DO 602 J=1,J0
  113. IF (ABS(AA(I0,J0-(J-1))).LT.1.D-3)THEN
  114.  
  115. ************************************************************************
  116. C PRISE EN COMPTE DES SOLUTIONS SOLIDES : METHODE 1
  117. * IF(NZDIM.NE.0)THEN
  118. * IF(J.EQ.J0)THEN
  119. * J0=J0+1
  120. * GOTO 601
  121. * ELSE
  122. * GOTO 602
  123. * ENDIF
  124. * ELSE
  125. *************************************************************************
  126.  
  127. GOTO 602
  128.  
  129. ************************************************************************
  130. * ENDIF
  131. *************************************************************************
  132.  
  133. ELSE
  134. NEX=NEX+1
  135. JEX(NEX)=J0-(J-1)
  136. ENDIF
  137. 602 CONTINUE
  138. C
  139. C
  140. IF (NEX.EQ.0) THEN
  141. IF(IIMPI.GE.1)THEN
  142. DO 60 IIJ=1,NXDIM
  143. IDXJ = IDX(IIJ)
  144. WRITE(6,670) IDXJ,XX(IIJ),GX(IIJ),TOT(IIJ),YY(IIJ),NAME(IDXJ)
  145. 60 CONTINUE
  146. ENDIF
  147. 670 FORMAT('0',I5,2X,1PE11.4,2X,0PF8.3,2(2X,1PE11.4),5X,A10)
  148. C WRITE(6,*) 'PHASE RULE VIOLATION'
  149. c modif PhM: Probleme dans la regle des phases.
  150. c on n'arrete pas le calcul mais on signale le probleme, erreur 7
  151. IEM=7
  152. c WRITE(6,*) 'Probleme pour la regle des phases'
  153. c CALL ERREUR(780)
  154. c modif PhM
  155. RETURN
  156. ENDIF
  157. C
  158. C....... SELECT JEXC AMONG JEX-ELEMENTS
  159. JEXC=JEX(1)
  160. IF (NEX.EQ.1) GOTO 666
  161. VVMIN=ABS(VBID(JEXC)/AA(I0,JEXC))
  162. DO 610 J=2,NEX
  163. JJ=JEX(J)
  164. VV=ABS(VBID(JJ)/AA(I0,JJ))
  165. IF (VV.GE.VVMIN) GOTO 610
  166. JEXC=JJ
  167. VVMIN=VV
  168. 610 CONTINUE
  169. C........ EXCHANGE COLUMNS JEXC AND J0
  170. 666 CONTINUE
  171. C
  172. C CALL TREXCO(SP1,SP2,JEXC,J0)
  173. IV=IDX(J0)
  174. IDX(J0)=IDX(JEXC)
  175. IDX(JEXC)=IV
  176. VV=XX(JEXC)
  177. XX(JEXC)=XX(J0)
  178. XX(J0)=VV
  179. VV=GX(JEXC)
  180. GX(JEXC)=GX(J0)
  181. GX(J0)=VV
  182. VV=TOT(JEXC)
  183. TOT(JEXC)=TOT(J0)
  184. TOT(J0)=VV
  185. IV=IONZ(J0)
  186. IONZ(J0)=IONZ(JEXC)
  187. IONZ(JEXC)=IV
  188. NAMINT=NAME(J0)
  189. NAME(J0)=NAME(JEXC)
  190. NAME(JEXC)=NAMINT
  191. DO 603 I=1,NYDIM
  192. VV=AA(I,JEXC)
  193. AA(I,JEXC)=AA(I,J0)
  194. AA(I,J0)=VV
  195. 603 CONTINUE
  196. C
  197. * write(6,*)'chmsl4 idx(j0)',IDX(J0),'idy(i0)',IDY(I0)
  198. * write(6,*)'chmsl4 aa(i0,j0)',AA(I0,J0)
  199. VV=VBID(JEXC)
  200. VBID(JEXC)=VBID(J0)
  201. VBID(J0)=VV
  202. NXS=J0-1
  203. NCS=I0-1
  204. C MODIFY A,T,V
  205. DO 600 I=1,NCS
  206. * write(6,*)'chmsl4 idy',idy(i)
  207. * write(6,*)'chmsl4 aa(io,jo)',aa(i0,j0),'aa(i,jo)',aa(i,j0)
  208. DO 604 J=1,NXS
  209. AA(I,J)=AA(I,J)-AA(I0,J)*AA(I,J0)/AA(I0,J0)
  210. * write(6,*)'chmsl4 idx',idx(j)
  211. * write(6,*)'chmsl4 aa(io,j)',aa(i0,j),'aa(i,j)',aa(i,j)
  212. 604 CONTINUE
  213. 600 CONTINUE
  214. * write(6,*)'chmsl4 idy(io)',idy(i0)
  215. DO 605 J=1,NXS
  216. TOT(J)=TOT(J)-AA(I0,J)*TOT(J0)/AA(I0,J0)
  217. * write(6,*)'chmsl4 idx',idx(j),'tot',TOT(J)
  218. * write(6,*)'chmsl4 aa(io,j)',aa(i0,j),'tot(jo)',tot(j0)
  219. * write(6,*)'chmsl4 aa(io,jo)',aa(i0,j0)
  220. 605 CONTINUE
  221.  
  222. ***********************************************************************
  223. C PRISE EN COMPTE DES SOLUTIONS SOLIDES : METHODE 1
  224. * IF(NZDIM.NE.0)THEN
  225. * IDY0=IDY(I0)
  226. * CALL CHIADY(IDZ,NZDIM,IDY0,ID0)
  227. * IF(ID0.NE.0)THEN
  228. * GAJ=0.D0
  229. * DO 606 IJ=1,NPDIM
  230. * IF(FF(ID0,IJ).NE.0.D0)THEN
  231. * GAJ=GAJ+FF(ID0,IJ)*LOG10(ABS(FF(ID0,IJ)))
  232. * ENDIF
  233. *606 CONTINUE
  234. * DO 607 I=1,NCS
  235. * GK(I)=GK(I)-AA(I,J0)*(GK(I0)-GAJ)/AA(I0,J0)
  236. *607 CONTINUE
  237. * ELSE
  238. * IF(NZDIM.NE.0)THEN
  239. * IDY0=IDY(I0)
  240. * CALL CHIADY(IDP,NPDIM,IDY0,ID0)
  241. * DO 606 K=1,NZDIM
  242. * IF(FF(K,ID0).NE.0.D0) GOTO 800
  243. *606 CONTINUE
  244. *800 CONTINUE
  245. * DO 607 I=1,NCS
  246. * IF(FF(K,ID0).EQ.0.D0)THEN
  247. * GK(I)=GK(I)-AA(I,J0)*GK(I0)/AA(I0,J0)
  248. * ELSE
  249. * LF=LOG10(ABS(FF(K,ID0)))
  250. * GK(I)=GK(I)-AA(I,J0)*(GK(I0)-LF)/AA(I0,J0)
  251. * ENDIF
  252. ** write(6,*)'chmsl4 idy',IDY(I),'gk',GK(I)
  253. *607 CONTINUE
  254. * ELSE
  255. ************************************************************************
  256.  
  257. DO 608 I=1,NCS
  258. GK(I)=GK(I)-AA(I,J0)*GK(I0)/AA(I0,J0)
  259. 608 CONTINUE
  260.  
  261. ***********************************************************************
  262. * ENDIF
  263. * ENDIF
  264. * ENDIF
  265. ***********************************************************************
  266.  
  267. DO 609 J=1,NXS
  268. VV=ABS(AA(I0,J)*VBID(J0)/AA(I0,J0))
  269. VBID(J)=DMAX1(VBID(J),VV)
  270. 609 CONTINUE
  271. 601 CONTINUE
  272. C
  273. RETURN
  274. END
  275. C
  276.  
  277.  
  278.  
  279.  
  280.  

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