Télécharger la plaquette Cast3M


fr en

Télécharger chimi2.eso

Retour à la liste

Numérotation des lignes : 

chimi2

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

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