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