1 : C CHINP SOURCE CHAT 05/01/12 21:57:46 5004 2 : SUBROUTINE CHINP(IDSCHI,LXMX,IOCHI1,IOCHI2) 3 : C 4 : C 5 : C======================================================================= 6 : C sp issu de TRIOEF 7 : C 8 : C 9 : C 10 : C LECTURE DE LA B.D.D. THERMODYNAMIQUE MINEQL 11 : C 12 : C====================================================================== 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : 16 : -INC SMLENTI 17 : POINTEUR MLXMX.MLENTI 18 : -INC CCOPTIO 19 : SEGMENT IDSCHI 20 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 21 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 22 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 23 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 24 : ENDSEGMENT 25 : C 26 : 27 : DIMENSION IAT(4),IDT(4) 28 : SEGMENT IZCOMP 29 : CHARACTER*8 NAM(NXD) 30 : INTEGER ION(NXD),IADXT(NXD) 31 : ENDSEGMENT 32 : 33 : 34 : NXDIM=IDX(/1) 35 : NYDIM=IDY(/1) 36 : NZDIM=IDZ(/1) 37 : NPDIM=IDP(/1) 38 : NXD=200 39 : NNN=NXDIM 40 : SEGINI IZCOMP 41 : 42 : C INITIALIZE ADDRESS 43 : DO 20 J=1,NXD 44 : IADXT(J)=0 45 : 20 CONTINUE 46 : C 47 : CBRUNO 48 : READ(IOCHI1,520) (NAM(J),J=1,NXD) 49 : READ(IOCHI1,530) (ION(J),J=1,NXD) 50 : * 51 : C WRITE(6,*)'chinp COMPO LU ' 52 : C WRITE(6,*)'chinp NNN',NNN 53 : C 54 : C INITIALIZE NN 55 : C 56 : C N3=0 57 : C 58 : 59 : C INPUT BASIS IN A MATRIX 60 : 61 : DO 200 I=1,NNN 62 : IDXT=IDX(I) 63 : IF(IDXT.GT.NXD)THEN 64 : INTERR(1)=IDXT 65 : C WRITE(6,*)'IDXT',IDXT 66 : C WRITE(6,*)'NDX',NDX 66 : CALL ERREUR(781) 67 : GO TO 500 68 : ENDIF 69 : CRUNO 70 : NAME(I)=' ' 71 : NAME(I)(1:8)=NAM(IDXT) 72 : IONZ(I)=ION(IDXT) 73 : * 74 : C IF (IDX(I).EQ.90) JSOH=I 75 : IADXT(IDXT)=I 76 : C X(I)=10.**GX(I) 77 : IDY(I)=IDX(I) 78 : AA(I,I)=1.0D0 79 : GK(I)=0.0D0 80 : 200 CONTINUE 81 : 82 : C WRITE(6,*)'chinp COMPOSANT SURFACE ' 83 : NN(1)=NNN 84 : 85 : C ***************** LECTURE DES DONNEES THERMODYNAMIQUES 86 : 87 : 88 : I=NN(1) 89 : DO 400 L=2,6 90 : * WRITE(6,*)' TYPE ',L 91 : I0=I 92 : READ(IOCHI2,510) IN 93 : C WRITE(6,*)'chinp NOMBRE ESPECE ' ,IN 94 : IF(IN.EQ.0) GO TO 400 95 : DO 300 II=1,IN 96 : READ(IOCHI2,510) IDYT,GKT,(IDT(J),IAT(J),J=1,4) 97 : DO 310 J=1,4 98 : JTEST=IDT(J) 99 : IF(JTEST.EQ.0) GO TO 310 100 : IF(IADXT(JTEST).EQ.0) GO TO 300 101 : 310 CONTINUE 102 : 103 : I=I+1 104 : IF (I.GT.NYDIM) THEN 105 : MOTERR(1:8)=' CHXMX ' 106 : MOTERR(9:16)='SUITENTI' 106 : CALL ERREUR(787) 107 : RETURN 108 : ENDIF 109 : IDY(I)=IDYT 110 : GK(I)=GKT 111 : 112 : C WRITE(6,*)'chinp ESPÈCE',IDY(I) 113 : DO 320 J=1,4 114 : JTEST=IDT(J) 115 : C IF (IDT(J).EQ.90) N3=N3+1 116 : IF(JTEST.EQ.0) GO TO 320 117 : IADTJT=IADXT(JTEST) 118 : AA(I,IADTJT)=IAT(J) 119 : C WRITE(6,*)'chinp COMP',IDT(J),AA(I,IADTJT) 120 : 320 CONTINUE 121 : 300 CONTINUE 122 : 123 : CMONI---------------LE 10 SEPT 91---------------------------- 124 : IF (L.EQ.5) THEN 125 : NOUVI=0 126 : * WRITE(6,*)' NMXCH ',NMXCH 127 : IF (LXMX.EQ.0) GOTO 270 128 : MLXMX=LXMX 129 : SEGACT MLXMX 130 : NMXCH=MLXMX.LECT(/1) 131 : 132 : CPATBOS------------------------------------------------------ 133 : C MISE EN IDP DES SOLIDES CHOISIS PAR L UTILISATEUR 134 : NPDIM=NMXCH 135 : SEGADJ IDSCHI 135 : CALL RSETI(IDP,MLXMX.LECT,NPDIM) 136 : IN5=I 137 : C 138 : *-----------------***------MONI------***------------------------------- 139 : * CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE 140 : * EN COMPTE;( AVEC MINEQL IL EXISTE UNE FACON BIEN SIMPLE : 141 : * METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5 142 : * (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION), 143 : * EN TYPE 6 : 144 : * NN(6)=NN(5)+NN(6) 145 : * NN(5)=0 146 : * PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS : 147 : * EX: 148 : * I5=5 149 : * I6=6 149 : * CALL EXTYP(02231,I6,I5) 150 : ********************************************************************** 151 : 152 : *C RECHERCHE DES MINERAUX NON PRIS EN COMPTE 153 : III=I 154 : C --- 155 : DO 266 ICHOI=I0+1,III 156 : DO 267 NM0=1,NMXCH 157 : IF (IDY(ICHOI).EQ.(MLXMX.LECT(NM0))) GOTO 269 158 : 267 CONTINUE 159 : 160 : IDY(ICHOI)=0 161 : GK(ICHOI)=0.D0 162 : CBRUNO 163 : DO 210 JK=1,NNN 164 : AA(ICHOI,JK)=0.D0 165 : 210 CONTINUE 166 : 167 : I=I-1 168 : GOTO 265 169 : 170 : 269 NOUVI=NOUVI+1 171 : IDY(I0+NOUVI)=IDY(ICHOI) 172 : GK(I0+NOUVI)=GK(ICHOI) 173 : CBRUNO 174 : DO 220 JK=1,NNN 175 : AA(I0+NOUVI,JK)=AA(ICHOI,JK) 176 : IF(ICHOI.NE.(I0+NOUVI)) AA(ICHOI,JK)=0.D0 177 : 220 CONTINUE 178 : 179 : 265 CONTINUE 180 : 266 CONTINUE 181 : DO 275 LIK = I0+NMXCH+1,IN5 182 : IDY(LIK)=0 183 : DO 274 JIK=1,NNN 184 : AA(LIK,JIK)=0.D0 185 : 274 CONTINUE 186 : 275 CONTINUE 187 : ENDIF 188 : 270 CONTINUE 189 : 190 : 191 : 192 : NN(L)=I-I0 193 : * WRITE(6,*)' NN(',L,')',NN(L) 194 : * write(6,*)'NN(4)',NN(4) 195 : 400 CONTINUE 196 : 197 : C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0 198 : IF(LXMX.NE.0) THEN 199 : SEGDES MLXMX 200 : ELSE 201 : NN123=NN(1)+NN(2)+NN(3)+1 202 : NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5) 203 : DO 600 N=NN123,NN45 204 : NPDIM=NPDIM+1 205 : SEGADJ IDSCHI 206 : IDP(NPDIM)=IDY(N) 207 : 600 CONTINUE 208 : ENDIF 209 : C 210 : C 211 : IF (I.LT.NYDIM) THEN 212 : NYDIM=I 213 : * write(6,*)'Fin chinp' 214 : * WRITE(6,*)' NXDIM ',NXDIM,' NYDIM ',NYDIM,' NPDIM ',NPDIM, 215 : * * ' NZDIM ',NZDIM 216 : SEGADJ IDSCHI 217 : ENDIF 218 : SEGSUP IZCOMP 219 : C 220 : C 221 : 510 FORMAT (I5,F9.2,4(I4,I3),T43,A5) 222 : C 520 FORMAT((7X,A10,3(8X,A10))) 223 : 520 FORMAT((7X,A8,2X,3(8X,A8,2X))) 224 : 530 FORMAT (40I2) 225 : C*****************REMISE EN TETE DES FICHIERS IOCHI1 ET IOCHI2****** 226 : 500 CONTINUE 227 : C REWIND(UNIT=IOCHI2) 228 : C CLOSE(UNIT=IOCHI2) 229 : C REWIND(UNIT=IOCHI1) 230 : C CLOSE(UNIT=IOCHI1) 231 : C******************************************************************* 232 : RETURN 233 : END 234 : 235 : 236 : 237 : 238 : 239 : 240 :
© Cast3M 2003 - All rights reserved.
Disclaimer