Télécharger la plaquette Cast3M


fr en

Télécharger chmsl4.eso

Retour à la liste

Numérotation des lignes : 

chmsl4

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

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