Télécharger chimi2.eso

Retour à la liste

Numérotation des lignes :

  1. C CHIMI2 SOURCE CB215821 16/04/21 21:15:42 8920
  2. SUBROUTINE CHIMI2
  3. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C OPERATEUR CHI2
  6. C
  7. C sous programme issu de TRIOEF
  8. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11. -INC CCOPTIO
  12. -INC SMLENTI
  13. -INC SMLREEL
  14. -INC SMTABLE
  15. -INC SMLMOTS
  16. -INC SMCHPOI
  17. -INC SMELEME
  18. -INC SMCOORD
  19. POINTEUR MLAA.MLREEL,MLOGK.MLREEL,MLFF.MLREEL
  20. POINTEUR MLIDX.MLENTI,MLIDY.MLENTI,MLIDZ.MLENTI,MLIDP.MLENTI
  21. POINTEUR MLNN.MLENTI,MLDECY.MLENTI
  22. POINTEUR MLIONZ.MLENTI,MLPREC.MLENTI,ICOTY3.MLENTI,MLIMPR.MLENTI
  23. POINTEUR MLNAME.MLMOTS,MLMOTX.MLMOTS,MLMSOR.MLMOTS,MLNESP.MLMOTS
  24. POINTEUR IZLOGC.MCHPOI,IZTOT.MCHPOI
  25. POINTEUR MCHAQU.MCHPOI,MCHFIX.MCHPOI,MCHSOL.MCHPOI,MCHSUR.MCHPOI
  26. POINTEUR MCHTY3.MCHPOI,MCHTY4.MCHPOI,MCHTY5.MCHPOI,MCHTY6.MCHPOI
  27. POINTEUR MCHPRE.MCHPOI,MCHPOL.MCHPOI,MCHGKS.MCHPOI,MCHLGC.MCHPOI
  28. POINTEUR MCHERR.MCHPOI
  29. POINTEUR IPTOT.MPOVAL,IPLGC.MPOVAL,IPTEMP.MPOVAL,IZFI.MPOVAL
  30. POINTEUR JZT3.MPOVAL,IZPRE.MPOVAL,ICHFIO.MPOVAL,ICHERR.MPOVAL
  31. POINTEUR ICHAQU.MPOVAL,ICHFIX.MPOVAL,ICHSOL.MPOVAL,ICHSUR.MPOVAL
  32. POINTEUR ICHTY3.MPOVAL,ICHPRE.MPOVAL,ICHTY5.MPOVAL,ICHTY6.MPOVAL
  33. POINTEUR ICHPOL.MPOVAL,ICHGKS.MPOVAL,ICHLGC.MPOVAL
  34. CHARACTER*4 NOMTOT
  35. CHARACTER*8 TYPEMA
  36. SEGMENT IDSCHI
  37. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  38. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  39. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  40. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  41. ENDSEGMENT
  42. SEGMENT SP2
  43. REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM)
  44. REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM)
  45. REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM)
  46. ENDSEGMENT
  47. SEGMENT IPTIDX
  48. INTEGER ITDX(NXDIM)
  49. ENDSEGMENT
  50. POINTEUR IDXTOT.IPTIDX,IDXLGC.IPTIDX
  51. SEGMENT IZVBID
  52. INTEGER JEX(NXDIM)
  53. REAL*8 VBID(NXDIM)
  54. ENDSEGMENT
  55. SEGMENT IZBID1
  56. INTEGER ID0(NYDIM,N4NXD),IDPP(N4N5)
  57. INTEGER ID0S(NZDIM,N4NPD)
  58. ENDSEGMENT
  59. SEGMENT IZRED
  60. INTEGER ITAB(NCR,2)
  61. REAL*8 ATAB(NCR,2)
  62. ENDSEGMENT
  63. SEGMENT IZTR
  64. REAL*8 A0(NXDIM)
  65. ENDSEGMENT
  66. C
  67.  
  68. C
  69. C LECTURE DE LA TABLE CHIMI1
  70. CALL CHMDEB(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  71. * MLNAME,MLIONZ,ITIDEN,ITREDO,ITEMPE,MLNESP)
  72. IF(IERR.NE.0)RETURN
  73. * write(6,*)'chimi2 itiden= ',ITIDEN
  74. C
  75. C LECTURE DE LA TABLE DES PARAMETRE
  76. CALL CHMPAR(EPS,ITMAX,ISOLM,IAFFI,PRECPE,NITEPE,NFI,IFIONI,
  77. * IZTYP4,IZTEMP,IZLOGC,IZTOT,IZCLIM,MLMSOR,DE,MAXDE,MLIMPR ,
  78. * ICALCLOG)
  79. IF(IERR.NE.0)RETURN
  80. SEGACT IZTOT,IZLOGC
  81. C
  82. C RECUPERATION DU MAILLAGE
  83. C ON CONTROLE LA COHERENCE ENTRE TOT ET LOGC
  84. NSOUPO = IZTOT.IPCHP(/1)
  85. IF (NSOUPO.NE.1) THEN
  86. MOTERR(1:8) = 'CHAMPOIN'
  87. CALL ERREUR(132)
  88. SEGDES IZTOT*NOMOD
  89. RETURN
  90. ENDIF
  91. MSOUPO=IZTOT.IPCHP(1)
  92. SEGACT MSOUPO
  93. MELEME=IGEOC
  94. INDIQ=1
  95. NBCOMP=-1
  96. NOMTOT=' '
  97. CALL QUEPOI(IZLOGC,MELEME,INDIQ,NBCOMP,NOMTOT)
  98. IF(INDIQ.LT.0)THEN
  99. CALL ERREUR(22)
  100. ENDIF
  101. IF(IERR.NE.0)RETURN
  102. C
  103. C LECTURE DE LA TABLE IDEN
  104. C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  105. C
  106. CALL CHMIDE(ITIDEN,MLCOMP,MLSOLU,MMSOLU,MLPREC,MMPREC,MLSURF,
  107. * MMSURF,MLTYP3,MMTYP3,MLTYP6,MMTYP6,MLPARF,MLREAC,MLIMMO,
  108. * MLPOLE,MMPOLE,MLSOSO,MMSOSO,LIMP3)
  109. IF(IERR.NE.0)RETURN
  110. C
  111. C LECTURE DE LA TABLE TEMPE(SI ELLE EXISTE)
  112. C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  113. CALL CHMTET(ITEMPE,LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  114. IF(IERR.NE.0)RETURN
  115. C
  116. C LECTURE DE LA TABLE REDOX(SI ELLE EXISTE)
  117. CALL CHMRED(ITREDO,IZRED)
  118. IF(IERR.NE.0)RETURN
  119. C
  120. C
  121. C ON ACTIVE LES SEGMENTS
  122. C ET ON DEFINIT LES TABLEAUX DE TRAVAIL
  123. SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  124. SEGACT MLIONZ,MLIDP
  125. NXDIM=MLIDX.LECT(/1)
  126. NYDIM=MLIDY.LECT(/1)
  127. NZDIM=MLIDZ.LECT(/1)
  128. NPDIM=MLIDP.LECT(/1)
  129. N4N5=MLNN.LECT(4)+MLNN.LECT(5)
  130. N4NXD=N4N5*NXDIM
  131. N4NPD=N4N5*NPDIM
  132. SEGINI IDSCHI
  133. SEGINI SP2,IZVBID,IZBID1
  134. SEGINI IZTR
  135. C
  136. C ON RECUPERE LES POINTEURS DES TABLEAUX DE VALEURS TOT ET LOGC
  137. C AINSI QUE L ORDRE DES COMPOSANTS DANS CES TABLEAUX
  138. MOTERR(5:8)='TOT '
  139. CALL CHMLST(IZTOT,MLIDX,IDXTOT,IPTOT)
  140. MOTERR(5:8)='LOGC'
  141. CALL CHMLST(IZLOGC,MLIDX,IDXLGC,IPLGC)
  142. IF(IERR.NE.0)RETURN
  143. NPN=IPTOT.VPOCHA(/1)
  144. C RECUPERATION DES AUTRES TABLEAUX
  145. IZFI=0
  146. IF(IFIONI.NE.0)THEN
  147. CALL LRCHT(IFIONI,IZFI,TYPEMA,IGEOM)
  148. IF(IERR.NE.0)RETURN
  149. ENDIF
  150. IPTEMP=0
  151. IF(IZTEMP.NE.0)THEN
  152. CALL LRCHT(IZTEMP,IPTEMP,TYPEMA,IGEOM)
  153. IF(IERR.NE.0)RETURN
  154. ENDIF
  155. ICOTY3=0
  156. JZT3=0
  157. IF(IZCLIM.NE.0)THEN
  158. C
  159. C INITIALISATION DE LA PRISE EN COMPTE DES ACTIVITES IMPOSEES
  160. C ON RESSORT JZT3
  161. CALL CHMTY3(IZCLIM,MMTYP3,MLTYP3,ICOTY3,JZT3)
  162. IF(IERR.NE.0)RETURN
  163. ENDIF
  164. C
  165. C
  166. C EXISTANCE DES PRECIPITES
  167. N2=0
  168. IZPRE=0
  169. MCHTY4=0
  170. IF(MMPREC.NE.0)THEN
  171. CALL CHMCRC(MMPREC,MELEME,NPN,MCHTY4,IZPRE)
  172. N2=IZPRE.VPOCHA(/2)
  173. ENDIF
  174. IF(IZTYP4.NE.0)THEN
  175. IF((MLPREC.EQ.0).OR.(MMPREC.EQ.0))THEN
  176. CALL ERREUR(21)
  177. RETURN
  178. ENDIF
  179. CALL CHMPRC(IZTYP4,MMPREC,IZPRE)
  180. ENDIF
  181. IF(IERR.NE.0)RETURN
  182. C
  183. C ON GENERE LE NOM INTERNE DES COMPOSANTS
  184. C X SUIVI DE L IDENTIFIANT IDX AVEC DES 0 ENTRE LES DEUX AU BESOIN
  185. JGN=4
  186. JGM=NXDIM
  187. SEGINI MLMOTX
  188. DO 1 I=1,NXDIM
  189. WRITE(MLMOTX.MOTS(I),110)MLIDX.LECT(I)
  190. 1 CONTINUE
  191. 110 FORMAT('X',I3.3)
  192. C
  193. C ON CREE LES CHPOIN POUR SAUVER LES RESULTATS
  194. CALL CHMCRC(MLMOTX,MELEME,NPN,MCHAQU,ICHAQU)
  195. CALL CHMCRC(MLMOTX,MELEME,NPN,MCHFIX,ICHFIX)
  196. CALL CHMCRC(MLMOTX,MELEME,NPN,MCHLGC,ICHLGC)
  197. c modif PhM: chpoint des erreur
  198. JGM=1
  199. SEGINI MLMOTS
  200. MOTS(1)='SCAL'
  201. CALL CHMCRC(MLMOTS,MELEME,NPN,MCHERR,ICHERR)
  202. SEGSUP MLMOTS
  203. JGM=NXDIM
  204. c modif Phm
  205. CALL CHMLSO(MLMSOR,ISORT)
  206. IF(IERR.NE.0)RETURN
  207. MCHGKS=0
  208. ICHGKS=0
  209. IF(ISORT.GE.1024)THEN
  210. IF(MMSOSO.NE.0)THEN
  211. * write(6,*)'chimi2 mmsoso',mmsoso
  212. CALL CHMCRC(MMSOSO,MELEME,NPN,MCHGKS,ICHGKS)
  213. * write(6,*)'chimi2 mchgks ichgks',mchgks,ichgks
  214. ELSE
  215. MOTERR(1:8)='SOSO '
  216. CALL ERREUR(-183)
  217. CALL ERREUR(21)
  218. RETURN
  219. ENDIF
  220. ISORT=ISORT-1024
  221. ENDIF
  222. MCHPOL=0
  223. ICHPOL=0
  224. IF(ISORT.GE.512)THEN
  225. IF(MMPOLE.NE.0)THEN
  226. * write(6,*)'chimi2 mmpole',mmpole
  227. CALL CHMCRC(MMPOLE,MELEME,NPN,MCHPOL,ICHPOL)
  228. ELSE
  229. MOTERR(1:8)='POLE '
  230. CALL ERREUR(-183)
  231. CALL ERREUR(21)
  232. RETURN
  233. ENDIF
  234. ISORT=ISORT-512
  235. ENDIF
  236. MCHSOL=0
  237. ICHSOL=0
  238. IF(ISORT.GE.256)THEN
  239. IF(MMSOLU.NE.0)THEN
  240. CALL CHMCRC(MMSOLU,MELEME,NPN,MCHSOL,ICHSOL)
  241. ELSE
  242. MOTERR(1:8)='SOLU '
  243. CALL ERREUR(-183)
  244. CALL ERREUR(21)
  245. RETURN
  246. ENDIF
  247. ISORT=ISORT-256
  248. ENDIF
  249. MCHSUR=0
  250. ICHSUR=0
  251. IF(ISORT.GE.128)THEN
  252. IF(MMSURF.NE.0)THEN
  253. CALL CHMCRC(MMSURF,MELEME,NPN,MCHSUR,ICHSUR)
  254. ELSE
  255. MOTERR(1:8)='SURF '
  256. CALL ERREUR(-183)
  257. CALL ERREUR(21)
  258. RETURN
  259. ENDIF
  260. ISORT=ISORT-128
  261. ENDIF
  262. MCHTY3=0
  263. ICHTY3=0
  264. IF(ISORT.GE.64)THEN
  265. IF(MMTYP3.NE.0)THEN
  266. CALL CHMCRC(MMTYP3,MELEME,NPN,MCHTY3,ICHTY3)
  267. ELSE
  268. MOTERR(1:8)='TYP3 '
  269. CALL ERREUR(-183)
  270. CALL ERREUR(21)
  271. RETURN
  272. ENDIF
  273. ISORT=ISORT-64
  274. ENDIF
  275. MCHPRE=0
  276. ICHPRE=0
  277. IF(ISORT.GE.32)THEN
  278. IF(MMPREC.NE.0)THEN
  279. CALL CHMCRC(MMPREC,MELEME,NPN,MCHPRE,ICHPRE)
  280. ELSE
  281. MOTERR(1:8)='PREC '
  282. CALL ERREUR(-183)
  283. CALL ERREUR(21)
  284. RETURN
  285. ENDIF
  286. ISORT=ISORT-32
  287. ENDIF
  288. MCHTY5=0
  289. ICHTY5=0
  290. IF(ISORT.GE.16)THEN
  291. IF(MMPREC.NE.0)THEN
  292. CALL CHMCRC(MMPREC,MELEME,NPN,MCHTY5,ICHTY5)
  293. ELSE
  294. MOTERR(1:8)='TYP5 '
  295. CALL ERREUR(-183)
  296. CALL ERREUR(21)
  297. RETURN
  298. ENDIF
  299. ISORT=ISORT-16
  300. ENDIF
  301. MCHTY6=0
  302. ICHTY6=0
  303. IF(ISORT.GE.8)THEN
  304. IF(MMTYP6.NE.0)THEN
  305. CALL CHMCRC(MMTYP6,MELEME,NPN,MCHTY6,ICHTY6)
  306. ELSE
  307. MOTERR(1:8)='TYP6 '
  308. CALL ERREUR(-183)
  309. CALL ERREUR(21)
  310. RETURN
  311. ENDIF
  312. ISORT=ISORT-8
  313. ENDIF
  314. MCHFIO=0
  315. ICHFIO=0
  316. IF(ISORT.GE.4)THEN
  317. JGM=1
  318. SEGINI MLMOTS
  319. MOTS(1)='SCAL'
  320. CALL CHMCRC(MLMOTS,MELEME,NPN,MCHFIO,ICHFIO)
  321. SEGSUP MLMOTS
  322. ISORT=ISORT-4
  323. ENDIF
  324. IF((ISORT.EQ.2).AND.(MMPREC.EQ.0))THEN
  325. MOTERR(1:8)='NTY4 '
  326. CALL ERREUR(-183)
  327. CALL ERREUR(21)
  328. RETURN
  329. ENDIF
  330. C
  331. C INITIALISATION
  332. IF(IERR.NE.0)RETURN
  333. LTMP=0
  334. IF(LGKMOD.NE.0)LTMP=IP3
  335. C DE=1.D0
  336. ISENS=0
  337. EPREC2=1.D-4*PRECPE
  338. SEGACT MELEME
  339. C
  340. C -------------------------------------------------------------------
  341. C BOUCLE SUR LES POINTS
  342. C -------------------------------------------------------------------
  343. DO 100 II=1,NPN
  344. TMP=25.D0
  345. Q99=0.D0
  346. PE=0.D0
  347. PEMIN=0.D0
  348. PEMAX=0.D0
  349. ICHSLX=0
  350. ICHDE=0
  351. C CHARGEMENT DE IDSCHI
  352. CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  353. * MLNAME,MLIONZ,IDSCHI,MLNESP)
  354. C WRITE(6,*)' GK apres CHMIDS '
  355. C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM)
  356. 120 FORMAT(6(1X,1PD12.5,I10))
  357. C CHARGEMENT EVENTUEL DE LGKMOD OU LGKTMP
  358. CALL CHMLGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  359. C CHARGEMENT DE SP2
  360. DO 6 J=1,NXDIM
  361. TOT(J)= IPTOT.VPOCHA(II,IDXTOT.ITDX(J))
  362. GX(J)= IPLGC.VPOCHA(II,IDXLGC.ITDX(J))
  363. XX(J)=10.D0**GX(J)
  364. IF ((IDX(J).NE.50).AND.(IDX(J).NE.99)) THEN
  365. IF(TOT(J).LE.0.D0)THEN
  366. TOT(J)=1.D-35
  367. ENDIF
  368. ENDIF
  369. 6 CONTINUE
  370. C segact iztot
  371. C call ecchpo(iztot)
  372. C segact iztot
  373. CALL INITD(GC,NYDIM,0.D0)
  374. CALL INITD(CC,NYDIM,0.D0)
  375. C write(6,*)' gx ',(gx(j),j=1,nxdim)
  376. C write(6,*)' xx ',(xx(j),j=1,nxdim)
  377. C write(6,*)' gk ',(gk(j),j=1,nydim)
  378. C
  379. C= MISE EN TYPE 4 DE CERTAINS MINERAUX PRECIPITABLES
  380. C
  381. IF(IZTYP4.NE.0)THEN
  382. NN4=MLPREC.LECT(/1)
  383. DO 18 IC4=1,NN4
  384. IF(IZPRE.VPOCHA(II,IC4).EQ.1.D0)THEN
  385. ID=MLPREC.LECT(IC4)
  386. LIN=5
  387. LEN=4
  388. CALL CHMREX(IDSCHI,LGKMOD,LGKTMP,ID,LIN,LEN)
  389. ENDIF
  390. 18 CONTINUE
  391. ENDIF
  392. C
  393. C= REMISE A ZERO DES FORCES IONIQUES
  394. XMU = 0.D0
  395. XMUNEW = 0.D0
  396. C
  397. IF (IZTEMP.NE.0) THEN
  398. TMPNEW = IPTEMP.VPOCHA(II,1)
  399. ELSE
  400. TMPNEW = 25.D0
  401. ENDIF
  402. C
  403. C====================
  404. C= CALCUL D'EQUILIBRE
  405. C====================
  406. C
  407. C
  408. C= INITIALISATION DE LA FORCE IONIQUE
  409. C
  410. C write(6,*)' XMUNEW XMU IZFI ',XMUNEW,XMU,IZFI
  411. IF (IZFI.EQ.0) THEN
  412. CALL CHMEST(IDX,IONZ,TOT,NXDIM,XMUNEW)
  413. ELSE
  414. XMUNEW = IZFI.VPOCHA(II,1)
  415. ENDIF
  416. C IMP=1
  417. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC a voir CCCCCCCCCCCCCCCCCCCCCCCCC
  418. C IF (IMP.GE.1) CALL IMPCHI(SP1,SP2,KK,J,NFI,IMP)
  419. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  420. C
  421. C= MODIFICATION DES LOGK DE XMU A XMUNEW ET DE TMP A TMPNEW
  422. C
  423. JNFI=1
  424. IF (IZCLIM.NE.0) THEN
  425. C ON RECALCULE LES INDICES CAR CHMTMS APPELE PAR CHMKMD PEUT MODIFIER
  426. C L'ORDRE DES IDY
  427. MC3 = ICOTY3.LECT(/1)
  428. IJ=NN(1)+NN(2)+1
  429. IK=NN(1)+NN(2)+NN(3)
  430. DO 7 IC3=1,MC3
  431. DO 8 IL=IJ,IK
  432. IF(IDY(IL).EQ.ICOTY3.LECT(IC3))THEN
  433. GK(IL) = GK(IL)+ JZT3.VPOCHA(II,IC3)
  434. GO TO 9
  435. ENDIF
  436. 8 CONTINUE
  437. 9 CONTINUE
  438. 7 CONTINUE
  439. ENDIF
  440. C- VERIFICATION DE LA PRESENCE DE L'ELECTRON PARMI LES COMPOSANTS
  441. C
  442. IOXYDO=0
  443. CALL CHMELE(IDSCHI,LGKMOD,LGKTMP,SP2,IOXYDO,Q99,PEMIN,PEMAX,DE,PE)
  444. ITERPE = 0
  445. ICHF=0
  446. IMAX=0
  447. IMIN=0
  448. C
  449. C-----------------------------
  450. C= BOUCLE SUR LA FORCE IONIQUE
  451. C-----------------------------
  452. C
  453. 5 CONTINUE
  454. C
  455. C= INITIALISATION
  456. C
  457. KK = 0
  458. CALL CHMKMD(IDSCHI,LGKMOD,LGKTMP,ICOTY3,LTMP,TMP,TMPNEW,
  459. * XMU,XMUNEW,GNEW)
  460. ITER = 0
  461. ITSOLI = 0
  462. C
  463. C------------------------
  464. C= BOUCLE SUR LES SOLIDES
  465. C------------------------
  466. C
  467. 80 CONTINUE
  468.  
  469. c On initialise a zero le numero de l'erreur
  470. IEM = 0
  471.  
  472. C
  473. C= MODIFICATION DES ÉQUATIONS PAR ÉLIMINATION DES SOLIDES
  474. C= (POUR TRSOL4 JNFI=1 CALCUL AVEC TOT, JNFI>1 CALCUL AVEC C)
  475. CALL CHMSL4(IDSCHI,SP2,IZVBID,JNFI,IEM)
  476. IF(IERR.NE.0)RETURN
  477.  
  478.  
  479. C Test de l'erreur dans CHMSL4
  480. IF (IEM.EQ.7) THEN
  481. write(6,*) 'Probleme: violation de la regle des phases ' ,
  482. & ' pour l element', II
  483. ENDIF
  484.  
  485. C
  486. C= RESOLUTION DU SYSTEME MATRICIEL
  487. C
  488. CALL CHMSLV(IDSCHI,SP2,ITMAX,EPS,ICALCLOG,IEM)
  489.  
  490.  
  491. C Test de l'erreur dans CHMSLV
  492. IF (IEM.NE.0) THEN
  493. C analyse du type d'erreur
  494. IF (IEM.EQ.8) THEN
  495. C erreur de type 8 : pb dans la resolution du systeme lineaire
  496. write(6,*) 'Probleme dans la resol du systeme lineaire ' ,
  497. & ' pour l element', II
  498. C INTERR(1)=II
  499. C CALL ERREUR(49)
  500. C RETURN
  501. ELSEIF (IEM.EQ.1) THEN
  502. c erreur de type 1 : nombre d'iteration superieur a ITMAX
  503. C ENDIF
  504. MOTERR(1:8)='ITMAX '
  505. CALL ERREUR(-314)
  506. IF(IOXYDO.EQ.2) THEN
  507. IF(ICHF.EQ.0 ) THEN
  508. C CHARGEMENT DE IDSCHI
  509. CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,
  510. * MLDECY,MLNAME,MLIONZ,IDSCHI,MLNESP)
  511. C CHARGEMENT EVENTUEL DE LGKMOD OU LGKTMP
  512. CALL CHMLGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  513. C CHARGEMENT DE SP2
  514. DO 36 J=1,NXDIM
  515. TOT(J)= IPTOT.VPOCHA(II,IDXTOT.ITDX(J))
  516. GX(J)= IPLGC.VPOCHA(II,IDXLGC.ITDX(J))
  517. XX(J)=10.D0**GX(J)
  518. IF(IDX(J).NE.50)THEN
  519. IF(TOT(J).LE.0.D0)THEN
  520. TOT(J)=1.D-25
  521. ENDIF
  522. ENDIF
  523. 36 CONTINUE
  524.  
  525. IF(IZTYP4.NE.0)THEN
  526. NN4=MLPREC.LECT(/1)
  527. DO 17 IC4=1,NN4
  528. IF(IZPRE.VPOCHA(II,IC4).EQ.1.D0)THEN
  529. ID=MLPREC.LECT(IC4)
  530. LIN=5
  531. LEN=4
  532. CALL CHMREX(IDSCHI,LGKMOD,LGKTMP,ID,LIN,LEN)
  533. ENDIF
  534. 17 CONTINUE
  535. ENDIF
  536. XMU = 0.D0
  537. XMUNEW = 0.D0
  538. C
  539. C IADSORB = NADSORB
  540. IF (IZTEMP.NE.0) THEN
  541. TMPNEW = IPTEMP.VPOCHA(II,1)
  542. ELSE
  543. TMPNEW = 25.D0
  544. ENDIF
  545. C
  546. IF (IZFI.EQ.0) THEN
  547. CALL CHMEST(IDX,IONZ,TOT,NXDIM,XMUNEW)
  548. ELSE
  549. XMUNEW = IZFI.VPOCHA(II,1)
  550. ENDIF
  551. JNFI = 1
  552. C write(6,*)' XMUNEW XMU avant CHMKMD 3 ',XMUNEW,XMU
  553. CALL CHMKMD(IDSCHI,LGKMOD,LGKTMP,ICOTY3,LTMP,TMP,TMPNEW,
  554. * XMU,XMUNEW,GNEW)
  555. C write(6,*)' XMUNEW XMU apres CHMKMD 3 ',XMUNEW,XMU
  556. *
  557. C WRITE(6,*)' GK avant CLIM2 ',(idy(j),GK(J),J=1,NYDIM)
  558. IF (IZCLIM.NE.0) THEN
  559. MC3 = ICOTY3.LECT(/1)
  560. IJ=NN(1)+NN(2)+1
  561. IK=NN(1)+NN(2)+NN(3)
  562. DO 39 IC3=1,MC3
  563. DO 37 IL=IJ,IK
  564. IF(IDY(IL).EQ.ICOTY3.LECT(IC3))THEN
  565. GK(IL) = GK(IL)+JZT3.VPOCHA(II,IC3)
  566. GO TO 38
  567. ENDIF
  568. 37 CONTINUE
  569. 38 CONTINUE
  570. 39 CONTINUE
  571. C WRITE(6,*)' GK apres CLIM2 ',(idy(j),GK(J),J=1,NYDIM)
  572. ENDIF
  573. IF(ITERPE.EQ.0) THEN
  574. PEMIN=PEMAX
  575. PEMAX =PEMAX + DE
  576. PE = PEMAX
  577. ICHDE=ICHDE+1
  578. ELSE
  579. IF(ISENS.EQ.1) THEN
  580. PEMIN=PEMAX
  581. PEMAX =PEMAX + DE
  582. PE = PEMAX
  583. ITERPE=0
  584. ICHDE=ICHDE+1
  585. ELSE
  586. PEMAX=PEMIN
  587. PEMIN =PEMIN - DE
  588. PE = PEMAX
  589. ITERPE=0
  590. ICHDE=ICHDE+1
  591. ENDIF
  592. ENDIF
  593. IF(ICHDE.GT.MAXDE)THEN
  594. MOTERR(1:8)='MDELPE '
  595. CALL ERREUR(-314)
  596. IF(IIMPI.NE.0)THEN
  597. WRITE(6,*) ' *************************',
  598. S '***********************'
  599. WRITE(6,*) ' ************* NOEUD ',NUM(1,II),
  600. S '*******************'
  601. WRITE(6,*) ' *************************',
  602. S '***********************'
  603. WRITE(6,*)' '
  604. WRITE(6,*)' *** TEMPERATURE ',REAL(TMPNEW),
  605. S ' DEGRE CELSIUS'
  606. WRITE(6,*)' '
  607. WRITE(6,19) XMUNEW
  608. WRITE(6,*)' '
  609. CALL CHMOUT(IDSCHI,SP2,IAFFI)
  610. ENDIF
  611. CALL ERREUR(460)
  612. RETURN
  613. ENDIF
  614. ID = 99
  615. LIN = 6
  616. LEN = 3
  617. CALL CHMREX(IDSCHI,LGKMOD,LGKTMP,ID,LIN,LEN)
  618. CALL CHIADY(IDX,NXDIM,99,IDXT)
  619. CALL CHIADY(IDY,NYDIM,99,IDYT)
  620. GK(IDYT) = PE
  621. XX(IDXT) = 10.D0 ** GX(IDXT)
  622. TOT(IDXT) = 0.D0
  623. GO TO 5
  624. ENDIF
  625. c FIN "IF (IOXYDO.EQ.2) THEN"
  626. ENDIF
  627.  
  628. c CALL ERREUR(460)
  629. c RETURN
  630.  
  631. c FIN "IF (IEM.NE.8) THEN"
  632. ENDIF
  633.  
  634. c FIN "IF (IEM.NE.0) THEN"
  635. ENDIF
  636. C
  637. C= CALCUL DES COMPOSANTS ÉLIMINÉS
  638. C= VÉRIFICATION DES PHASES PRÉCIPITÉS OU AQUEUSES
  639. C
  640. CALL CHMSLX(IDSCHI,SP2,KK,JNFI,NFI,LGKMOD,LGKTMP,IZBID1)
  641. IF (KK.NE.0) THEN
  642. * write(6,*)'chimi2 kk',KK
  643. ITSOLI = ITSOLI + 1
  644. * write(6,*)'chimi2 itsoli',ITSOLI,'isolm',ISOLM
  645. IF (ITSOLI.GT.ISOLM) THEN
  646. MOTERR(1:8)='ITERSOLI'
  647. CALL ERREUR(-314)
  648. IF (IIMPI.GT.0)THEN
  649. IF (JNFI.EQ.NFI-1) CALL CHMOUT(IDSCHI,SP2,IAFFI)
  650. ENDIF
  651. IF(IOXYDO.EQ.2)THEN
  652. ICHSLX=ICHSLX+1
  653. IF(ICHSLX.GE.MAXDE)THEN
  654. CALL ERREUR(460)
  655. RETURN
  656. ENDIF
  657. ENDIF
  658. GOTO 21
  659. ENDIF
  660. C
  661. C---------------
  662. GOTO 80
  663. C---------------
  664. C
  665. ENDIF
  666. C
  667. C= CALCUL DE LA FORCE IONIQUE
  668. C
  669. 21 CONTINUE
  670. * write(6,*)'chimi2 appel de chmout'
  671. * write(6,*)'noeud:',num(1,II)
  672. * write(6,19) xmunew
  673. * call chmout(idschi,sp2,affi)
  674. JNFI = JNFI + 1
  675. CALL CHMION(IDSCHI,SP2,XMUNEW)
  676. * write(6,*)'chimi2 nfi',nfi,'jnfi',jnfi
  677.  
  678. C
  679. C-------------------------
  680. IF (JNFI.LT.NFI) GOTO 5
  681. C-------------------------
  682. C
  683. C- TEST D'ARRET DU DICHOTOMIE LOSQUE ON IMPOSE UNE QUANTITE DE E-
  684. C
  685. IF (IOXYDO.EQ.2) THEN
  686. CCC
  687. JNFI = 1
  688. CCC
  689. ITERPE = ITERPE + 1
  690. CALL CHIADY(IDY,NYDIM,99,IPOS99)
  691. IF (ITERPE.EQ.1) THEN
  692. QSTO = - CC(IPOS99)
  693. Q99MAX = QSTO
  694. PE = PEMIN
  695. IF (ABS((QSTO -Q99)/Q99).LE.EPREC2) THEN
  696. GO TO 53
  697. ENDIF
  698. C!!!
  699. CALL CHIADY(IDX,NXDIM,99,IDXT)
  700. CALL CHIADY(IDY,NYDIM,99,IDYT)
  701. GK(IDYT) = PE
  702. GX(IDXT) =-GK(IDYT)
  703. XX(IDXT) = 10.D0 ** GX(IDXT)
  704. TOT(IDXT) = 0.D0
  705. C!!!!!!!
  706. GOTO 5
  707. ENDIF
  708. QFIND = - CC(IPOS99)
  709. IF(IMAX.EQ.1) THEN
  710. Q99MAX= - CC(IPOS99)
  711. ENDIF
  712. IF(IMIN.EQ.1) THEN
  713. Q99MIN= - CC(IPOS99)
  714. ENDIF
  715. IF (ITERPE.EQ.2.AND.IMAX+IMIN.EQ.0) THEN
  716. Q99MIN = QFIND
  717. IF (QFIND.GE.QSTO) THEN
  718. ISENS =-1
  719. ELSE
  720. ISENS = 1
  721. ENDIF
  722. IF (ABS((QFIND-Q99)/Q99).LE.EPREC2) THEN
  723. GO TO 53
  724. ENDIF
  725. ENDIF
  726. IF(ICHF.EQ.0) THEN
  727. IF((Q99-Q99MIN)*(Q99MAX-Q99).GE.0.D0)THEN
  728. ICHF=1
  729. IMAX=0
  730. IMIN=0
  731. ELSEIF((Q99-Q99MAX)*(Q99MAX-Q99MIN).GT.0.D0 ) THEN
  732. IF(Q99.GT.Q99MAX)ITERPE = 1
  733. Q99MIN=Q99MAX
  734. IMAX=1
  735. IMIN=0
  736. PEMIN=PEMAX
  737. PEMAX=PEMAX+DE
  738. PE = PEMAX
  739. ICHDE=ICHDE+1
  740. GO TO 55
  741. C PE < PEMAX = F(PH)
  742. ELSEIF((Q99MIN-Q99)*(Q99MAX-Q99MIN).GT.0.D0 ) THEN
  743. IF(Q99.GT.Q99MAX)ITERPE = 1
  744. Q99MAX=Q99MIN
  745. IMAX=0
  746. IMIN=1
  747. PEMAX=PEMIN
  748. PEMIN=PEMIN - DE
  749. PE = PEMIN
  750. ICHDE=ICHDE+1
  751. GO TO 55
  752. C PE > PEMIN = F(PH)
  753. ENDIF
  754. ENDIF
  755. IF (ABS((QFIND-Q99)/Q99).LE.PRECPE) THEN
  756. GO TO 53
  757. ENDIF
  758. C IF(ITERPE.GT.2) THEN
  759. C IF( ABS(PEMAX - PE).LE.1.D-15) THEN
  760. C CALL CHMCHL(IDSCHI,SP2,IZTR,PE)
  761. C GO TO 54
  762. C ENDIF
  763. C IF( ABS(PE - PEMIN).LE.1.D-15) THEN
  764. C CALL CHMCHL(IDSCHI,SP2,IZTR,PE)
  765. C GO TO 54
  766. C ENDIF
  767. C ENDIF
  768. IF (ISENS.EQ.1) THEN
  769. IF (QFIND.GT.Q99) THEN
  770. PEMAX = PE
  771. Q99MAX = QFIND
  772. ELSE
  773. PEMIN = PE
  774. Q99MIN = QFIND
  775. ENDIF
  776. ELSE
  777. IF (QFIND.GT.Q99) THEN
  778. PEMIN = PE
  779. Q99MIN = QFIND
  780. ELSE
  781. PEMAX = PE
  782. Q99MAX = QFIND
  783. ENDIF
  784. ENDIF
  785. IF (MOD(ITERPE,2).EQ.0) THEN
  786. QTETA = (LOG10(Q99) -LOG10(Q99MAX))
  787. S / (LOG10(Q99MIN) - LOG10(Q99MAX))
  788. ELSE
  789. QTETA = 0.5D0
  790. ENDIF
  791. PE = QTETA * PEMIN + (1.D0 - QTETA) * PEMAX
  792. 55 CONTINUE
  793. IF(ICHDE.GT.MAXDE)THEN
  794. MOTERR(1:8)='MDELPE '
  795. CALL ERREUR(-314)
  796. IF(IIMPI.NE.0)THEN
  797. WRITE(6,*) ' *************************',
  798. S '***********************'
  799. WRITE(6,*) ' ************* NOEUD ',NUM(1,II),
  800. S '*******************'
  801. WRITE(6,*) ' *************************',
  802. S '***********************'
  803. WRITE(6,*)' '
  804. WRITE(6,*)' *** TEMPERATURE ',REAL(TMPNEW),
  805. S ' DEGRE CELSIUS'
  806. WRITE(6,*)' '
  807. WRITE(6,19) XMUNEW
  808. WRITE(6,*)' '
  809. CALL CHMOUT(IDSCHI,SP2,IAFFI)
  810. ENDIF
  811. CALL ERREUR(460)
  812. RETURN
  813. ENDIF
  814. IF (ITERPE.LE.NITEPE) THEN
  815. CALL CHIADY(IDX,NXDIM,99,IDXT)
  816. CALL CHIADY(IDY,NYDIM,99,IDYT)
  817. GK(IDYT) = PE
  818. GX(IDXT) =-GK(IDYT)
  819. XX(IDXT) = 10.D0 ** GX(IDXT)
  820. TOT(IDXT) = 0.D0
  821. C!!!!!!!
  822. GOTO 5
  823. ELSE
  824. MOTERR(1:8)='NITERPE'
  825. CALL ERREUR(-314)
  826. IF(IIMPI.GT.1)THEN
  827. WRITE(6,*) ' '
  828. WRITE(6,*) ' ** NON CONVERGENCE DICHOTOMIE PE **'
  829. WRITE(6,*) ' ** NOEUD **',II
  830. WRITE(6,'(A20,3D15.8)') ' PE PEMAX PEMIN ',
  831. * PE,PEMAX,PEMIN
  832. WRITE(6,'(A20,3D15.8)') ' PEMAX(MIN) - PE ',
  833. * PEMAX-PE,PE-PEMIN
  834. WRITE(6,'(A20,3D15.8)') ' Q QMAX QMIN ',
  835. * Q99,Q99MAX,Q99MIN
  836. WRITE(6,'(A20,3D15.8)') ' QMAX(MIN) - Q /Q ',
  837. * (Q99MAX-Q99)/Q99,(Q99-Q99MIN)/Q99
  838. ENDIF
  839. ENDIF
  840. *
  841. 53 CONTINUE
  842. CALL CHIADY(IDX,NXDIM,99,IDXT)
  843. CALL CHIADY(IDY,NYDIM,99,IDYT)
  844. GK(IDYT) = PE
  845. GX(IDXT) = -PE
  846. XX(IDXT) = 10.D0 ** GX(IDXT)
  847. TOT(IDXT) = Q99
  848. * WRITE(6,*)' PEFINAL 1 ',PE,' ITERPE ',ITERPE,'MAX '
  849.  
  850. IDECY(IDYT)=0
  851. CALL CHMCHL(IDSCHI,SP2,IZTR,PE)
  852. ENDIF
  853. 54 CONTINUE
  854. C
  855. C
  856. C= BILAN TOTAUX ET AQUEUX POUR CHAQUE COMPOSANT
  857. C
  858. CALL CHMFIX(IDSCHI,SP2,IZRED,IOXYDO,LIMP3)
  859. C
  860. C= IMPRESSION DE CONTROLE
  861. C
  862. IF (IIMPI.NE.0) THEN
  863. IF(MLIMPR.GT.0) THEN
  864. NPIMPR=MLIMPR.LECT(/1)
  865. DO 56 I=1,NPIMPR
  866. IF(MLIMPR.LECT(I).EQ.NUM(1,II))GO TO 57
  867. 56 CONTINUE
  868. GO TO 58
  869. ENDIF
  870. 57 CONTINUE
  871. WRITE(6,*) ' *************************',
  872. S '***********************'
  873. WRITE(6,*) ' ************* NOEUD ',NUM(1,II),
  874. S '*******************'
  875. WRITE(6,*) ' *************************',
  876. S '***********************'
  877. WRITE(6,*)' '
  878. * WRITE(6,*)' *** TEMPERATURE ', TMPNEW ,' DEGRE CELSIUS'
  879. WRITE(6,*)' *** TEMPERATURE ',REAL(TMPNEW),
  880. S ' DEGRE CELSIUS'
  881. WRITE(6,*)' '
  882. WRITE(6,19) XMUNEW
  883. WRITE(6,*)' '
  884. CALL CHMOUT(IDSCHI,SP2,IAFFI)
  885. 19 FORMAT(8X,'CALCULATED IONIC STRENGTH = ',1PE12.4)
  886. ENDIF
  887. 58 CONTINUE
  888. C
  889. C====================================
  890. C= CHARGEMENT DES RESULTATS
  891. C====================================
  892. C
  893. C
  894. C= FORCE IONIQUE
  895. C
  896. IF (ICHFIO.NE.0) THEN
  897. ICHFIO.VPOCHA(II,1)= XMU
  898. ENDIF
  899. C
  900. C
  901. JI = NN(1)+NN(2)
  902. JJ = NN(1)+NN(2)+NN(3)+1
  903. JK = NN(1)+1
  904. JL = NN(1)+NN(2)+NN(3)+NN(4)
  905. JJA = MLNN.LECT(1)+MLNN.LECT(2)+MLNN.LECT(3)
  906. C write(6,*)' NN(1),NN(2),NN(3) ',NN(1),NN(2),NN(3)
  907. C
  908. C ESPECES SOLUBLES
  909. C
  910. IF (ICHSOL.NE.0) THEN
  911. KK=0
  912. DO 30 K=1,JI
  913. IDYT = MLIDY.LECT(K)
  914. IF(MLDECY.LECT(K).EQ.0)THEN
  915. DO 29 J=1,JI
  916. IF (IDY(J).EQ.IDYT) THEN
  917. KK=KK+1
  918. ICHSOL.VPOCHA(II,KK)=CC(J)
  919. GOTO 31
  920. ENDIF
  921. 29 CONTINUE
  922. ENDIF
  923. 31 CONTINUE
  924. 30 CONTINUE
  925. IF(IOXYDO.EQ.2)THEN
  926. KK=KK+1
  927. ICHSOL.VPOCHA(II,KK)=10.D0**(-PE)
  928. ENDIF
  929. ENDIF
  930. C
  931. C ESPECES PRECIPITES
  932. C
  933. IF (ICHPRE.NE.0) THEN
  934. DO 41 K=1,N2
  935. IDYT = MLIDY.LECT(JJA+K )
  936. DO 40 J=JJ,JL
  937. IF (IDY(J).EQ.IDYT) THEN
  938. ICHPRE.VPOCHA(II,K) = CC(J)
  939. GOTO 41
  940. ENDIF
  941. 40 CONTINUE
  942. 41 CONTINUE
  943. ENDIF
  944. C
  945. C ESPECES DE SURFACE
  946. C
  947. IF (ICHSUR.NE.0) THEN
  948. KK = 0
  949. DO 50 K=1,JI
  950. IF ( MLDECY.LECT(K).NE.0 ) THEN
  951. IDYT = MLIDY.LECT(K)
  952. DO 51 J=1,JI
  953. IF (IDY(J).EQ.IDYT) THEN
  954. KK = KK+1
  955. ICHSUR.VPOCHA(II,KK)=CC(J)
  956. GOTO 52
  957. ENDIF
  958. 51 CONTINUE
  959. 52 CONTINUE
  960. ENDIF
  961. 50 CONTINUE
  962. ENDIF
  963. C
  964. C= TYP3
  965. C
  966. IF (MCHTY3.NE.0) THEN
  967. JJ = NN(1) + NN(2) + NN(3)
  968. JK = JJ - JI
  969. DO 343 K=1,JK
  970. IDYT = MLIDY.LECT(JI+K)
  971. DO 342 J=JI+1,JJ
  972. IF (IDY(J).EQ.IDYT) THEN
  973. ICHTY3.VPOCHA(II,K)=CC(J)
  974. GOTO 341
  975. ENDIF
  976. 342 CONTINUE
  977. 341 CONTINUE
  978. 343 CONTINUE
  979. ENDIF
  980. C
  981. C= TYP5
  982. C
  983. IF (MCHTY5.NE.0) THEN
  984. JJ = NN(1) + NN(2) + NN(3)
  985. JK = NN(5)
  986. JM = NN(1) + NN(2) + NN(3) + NN(4) + NN(5)
  987. C write(6,*)' jj jk jm jl',jj,jk,jm,jl
  988. DO 543 K=1,JK
  989. IDYT = IDY(JL+K)
  990. DO 542 J=JJ+1,JM
  991. IF (MLIDY.LECT(J).EQ.IDYT) THEN
  992. C write(6,*)' idyt,j,CC(JL+K) ',idyt,j,CC(JL+K)
  993. ICHTY5.VPOCHA(II,J-JJ) = CC(JL+K)
  994. GOTO 541
  995. ENDIF
  996. 542 CONTINUE
  997. 541 CONTINUE
  998. 543 CONTINUE
  999. ENDIF
  1000. C
  1001. C= TYP6
  1002. C
  1003. IF (MCHTY6.NE.0) THEN
  1004. JJ = NN(1) + NN(2) + NN(3) + NN(4) + NN(5)
  1005. JK = NN(6)
  1006. JL = NN(1) + NN(2) + NN(3) + NN(4) + NN(5) + NN(6)
  1007. DO 642 K=1,JK
  1008. IDYT = MLIDY.LECT(JJ+K)
  1009. DO 643 J=JJ+1,JL
  1010. IF (IDY(J).EQ.IDYT) THEN
  1011. ICHTY6.VPOCHA(II,K)=CC(J)
  1012. GOTO 641
  1013. ENDIF
  1014. 643 CONTINUE
  1015. 641 CONTINUE
  1016. 642 CONTINUE
  1017. ENDIF
  1018. C
  1019. C POLES
  1020. C
  1021. IF(MCHPOL.NE.0)THEN
  1022. JJ = NN(1) + NN(2) + NN(3) + NN(4) + NN(5)
  1023. JK = NN(6)
  1024. KZZ=0
  1025. DO K=1,JK
  1026. IDYT=MLIDY.LECT(JJ+K)
  1027. DO J=1,NPDIM
  1028. IF(IDP(J).EQ.IDYT)THEN
  1029. DO KZ=1,NZDIM
  1030. IF(FF(KZ,J).NE.0)THEN
  1031. KZZ=KZZ+1
  1032. ICHPOL.VPOCHA(II,KZZ)=FF(KZ,J)
  1033. * write(6,*)'chimi2 ichpol.vpocha',ichpol.vpocha(II,KZZ)
  1034. GOTO 647
  1035. ENDIF
  1036. END DO
  1037. ENDIF
  1038. END DO
  1039. 647 CONTINUE
  1040. END DO
  1041. ENDIF
  1042. * write(6,*)'chimi2 ichpol.vpocha(/2)',ichpol.vpocha(/2)
  1043. C
  1044. C LOGK DES SOLUTIONS SOLIDES
  1045. C
  1046. IF(MCHGKS.NE.0)THEN
  1047. JJ=NN(1)+NN(2)+NN(3)
  1048. JK=NZDIM
  1049. JL=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+NN(6)
  1050. DO K=1,JK
  1051. IDZT=IDZ(K)
  1052. * write(6,*)'chimi2 idzt',idzt
  1053. DO J=JJ+1,JL
  1054. IF(IDY(J).EQ.IDZT)THEN
  1055. ICHGKS.VPOCHA(II,K)=GK(J)
  1056. * write(6,*)'chimi2 ichgks.vpocha',ichgks.vpocha(II,K)
  1057. GOTO 648
  1058. ENDIF
  1059. END DO
  1060. 648 CONTINUE
  1061. END DO
  1062. ENDIF
  1063. * write(6,*)'chimi2 ichgks.vpocha(/2)',ichgks.vpocha(/2)
  1064. C
  1065. C= MISE EN MEMOIRE DES MINERAUX PRECIPITES
  1066. C
  1067. IF((MCHTY4.NE.0).AND.(ISORT.EQ.2)) THEN
  1068. JJB = NN(1) + NN(2) + NN(3) + 1
  1069. JL = NN(1) + NN(2) + NN(3) + NN(4)
  1070. DO 90 K=1,N2
  1071. IDYT = MLIDY.LECT(JJA+K )
  1072. DO 91 J=JJB,JL
  1073. IF (IDY(J).EQ.IDYT) THEN
  1074. IF (CC(J).GT.1.D-27) THEN
  1075. IZPRE.VPOCHA(II,K)=1.D0
  1076. ENDIF
  1077. GOTO 90
  1078. ENDIF
  1079. 91 CONTINUE
  1080. 90 CONTINUE
  1081. ENDIF
  1082.  
  1083. C
  1084. C= MISE EN MEMOIRE DES MINERAUX DISSOUS
  1085. C
  1086. IF((MCHTY4.NE.0).AND.(ISORT.EQ.2)) THEN
  1087. JJB = NN(1) + NN(2) + NN(3) + NN(4) + 1
  1088. JL = NN(1) + NN(2) + NN(3) + NN(4) + NN(5)
  1089. DO 92 K=1,N2
  1090. IDYT = MLIDY.LECT(JJA+K )
  1091. DO 93 J=JJB,JL
  1092. IF (IDY(J).EQ.IDYT) THEN
  1093. IZPRE.VPOCHA(II,K)=0.
  1094. GOTO 92
  1095. ENDIF
  1096. 93 CONTINUE
  1097. 92 CONTINUE
  1098. ENDIF
  1099.  
  1100.  
  1101.  
  1102. C
  1103. C= MISE EN MEMOIRE DU CODE D'ERREUR
  1104. C
  1105. IF (ICHERR.NE.0) THEN
  1106. ICHERR.VPOCHA(II,1)= IEM
  1107. ENDIF
  1108.  
  1109. C
  1110. C==================================================
  1111. C= CHARGEMENT DES CHPOIN DE TRAVAIL
  1112. C==================================================
  1113. C
  1114. DO 60 JJ=1,NXDIM
  1115. DO 60 J=1,NXDIM
  1116. IF (IDX(J).EQ.MLIDX.LECT(JJ)) THEN
  1117. ICHAQU.VPOCHA(II,JJ) = TOTAQ(J)
  1118. ICHFIX.VPOCHA(II,JJ) = TOTFIX(J)
  1119. ICHLGC.VPOCHA(II,JJ) = GX(J)
  1120. GOTO 60
  1121. ENDIF
  1122.  
  1123.  
  1124. 60 CONTINUE
  1125.  
  1126.  
  1127.  
  1128. C
  1129. C------------------------------------
  1130. C= ETIQUETTE DE BOUCLE SUR LES POINTS
  1131. C------------------------------------
  1132. C
  1133. 100 CONTINUE
  1134. C LE MENAGE
  1135. IF((MCHTY4.NE.0).AND.(ISORT.NE.2))THEN
  1136. MCHPOI=MCHTY4
  1137. MSOUPO=IPCHP(1)
  1138. MPOVAL=IZPRE
  1139. SEGSUP MPOVAL,MSOUPO,MCHPOI
  1140. MCHTY4=0
  1141. IZPRE=0
  1142. ENDIF
  1143. SEGSUP IDSCHI
  1144. SEGSUP SP2,IZVBID,IZBID1
  1145. SEGSUP MLMOTX,IZTR
  1146. SEGSUP IDXTOT,IDXLGC
  1147. C
  1148. C ON DESACTIVE LES DONNEES
  1149. SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  1150. SEGDES MLIONZ,MLIDP
  1151. MLENTI=MLCOMP
  1152. SEGDES MLENTI
  1153. IF(MLSOSO.NE.0)THEN
  1154. * write(6,*)'chimi2 desactivation mlsoso',mlsoso
  1155. MLENTI=MLSOSO
  1156. MLMOTS=MMSOSO
  1157. SEGDES MLENTI,MLMOTS
  1158. ENDIF
  1159. IF(MLPOLE.NE.0)THEN
  1160. MLENTI=MLPOLE
  1161. MLMOTS=MMPOLE
  1162. SEGDES MLENTI,MLMOTS
  1163. ENDIF
  1164. IF(MLSOLU.NE.0)THEN
  1165. MLENTI=MLSOLU
  1166. MLMOTS=MMSOLU
  1167. SEGDES MLENTI,MLMOTS
  1168. ENDIF
  1169. IF(MLPREC.NE.0)THEN
  1170. MLENTI=MLPREC
  1171. MLMOTS=MMPREC
  1172. SEGDES MLENTI,MLMOTS
  1173. ENDIF
  1174. IF(MLSURF.NE.0)THEN
  1175. MLENTI=MLSURF
  1176. MLMOTS=MMSURF
  1177. SEGDES MLENTI,MLMOTS
  1178. ENDIF
  1179. IF(MLTYP3.NE.0)THEN
  1180. MLENTI=MLTYP3
  1181. MLMOTS=MMTYP3
  1182. SEGDES MLENTI,MLMOTS
  1183. ENDIF
  1184. IF(MLTYP6.NE.0)THEN
  1185. MLENTI=MLTYP6
  1186. MLMOTS=MMTYP6
  1187. SEGDES MLENTI,MLMOTS
  1188. ENDIF
  1189. IF(MLPARF.NE.0)THEN
  1190. MLENTI=MLPARF
  1191. SEGDES MLENTI
  1192. ENDIF
  1193. IF(MLREAC.NE.0)THEN
  1194. MLENTI=MLREAC
  1195. SEGDES MLENTI
  1196. ENDIF
  1197. IF(MLIMMO.NE.0)THEN
  1198. MLENTI=MLIMMO
  1199. SEGDES MLENTI
  1200. ENDIF
  1201. SEGDES IPTOT,IPLGC
  1202.  
  1203. IF(IZTEMP.NE.0)THEN
  1204. SEGDES IPTEMP
  1205. ENDIF
  1206. IF(MLIMPR.NE.0)THEN
  1207. MLENTI=MLIMPR
  1208. SEGDES MLENTI
  1209. ENDIF
  1210. IF(IZFI.NE.0)THEN
  1211. SEGDES IZFI
  1212. ENDIF
  1213. IF(IZCLIM.NE.0)THEN
  1214. SEGDES JZT3
  1215. SEGSUP ICOTY3
  1216. ENDIF
  1217. IF(IZRED.NE.0)THEN
  1218. SEGSUP IZRED
  1219. ENDIF
  1220. SEGDES MELEME
  1221. CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  1222. C
  1223. C ON CREE LA TABLE RESULTAT
  1224. CALL CHMSRT(MCHAQU,MCHFIX,MCHSOL,MCHSUR,MCHTY3,MCHTY4,MCHTY5,
  1225. * MCHTY6,MCHFIO,MCHPRE,MCHPOL,MCHGKS,MCHLGC,MCHERR)
  1226. RETURN
  1227. END
  1228.  
  1229.  
  1230.  
  1231.  
  1232.  
  1233.  
  1234.  
  1235.  
  1236.  
  1237.  
  1238.  
  1239.  
  1240.  

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