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