1 : C CHINPS SOURCE CHAT 05/01/12 21:57:51 5004 2 : SUBROUTINE CHINPS(IDSCHI,LXMX,IOCHI1,IOCHI2) 3 : C 4 : C 5 : C======================================================================= 6 : C 7 : C 8 : C !!!ATTENTION! POUR LE CHOIX DES MINERAUX A CONSIDERER CF CHINP 9 : C ------------------------------------------------------------------ 10 : C ATTENTION| 11 : C SP DE LECTURE CORRESPONDANT A LA BASE DE DONNEES DE STRASBOURG 12 : C SOUS FORMAT MINEQL 13 : C et aux bases issues de CHESS utilisables par CASTEM 14 : C 15 : C 16 : C====================================================================== 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8(A-H,O-Z) 19 : -INC SMLENTI 20 : POINTEUR MLXMX.MLENTI 21 : -INC CCOPTIO 22 : CHARACTER*5 MOCLE 23 : CHARACTER*32 NAMLXM 24 : LOGICAL LIBRE 25 : SEGMENT IDSCHI 26 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 27 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 28 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 29 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 30 : ENDSEGMENT 31 : C 32 : SEGMENT ITRAV 33 : REAL*8 CIAT(NXCMP) 34 : INTEGER IDT(NXCMP) 35 : ENDSEGMENT 36 : C 37 : SEGMENT IZCOMP 38 : CHARACTER*32 NAM(NXD) 39 : INTEGER ION(NXD),IADXT(NXD) 40 : ENDSEGMENT 41 : 42 : NXDIM=IDX(/1) 43 : NYDIM=IDY(/1) 44 : NZDIM=IDZ(/1) 45 : NPDIM=IDP(/1) 46 : LIBRE=.TRUE. 47 : READ(IOCHI1,590)NXD,NAMLXM 48 : IF(NAMLXM(1:10).NE.'COMPOSANTS')THEN 49 : NXD=200 50 : BACKSPACE IOCHI1 51 : LIBRE=.FALSE. 52 : ENDIF 53 : NNN=NXDIM 54 : NOUVI=0 55 : SEGINI IZCOMP 56 : 57 : C INITIALIZE ADDRESS 58 : DO 20 J=1,NXD 59 : IADXT(J)=0 60 : NAM(J)=' ' 61 : 20 CONTINUE 62 : C 63 : CBRUNO 64 : IF(LIBRE)THEN 65 : READ(IOCHI1,580) (NAM(J),J=1,NXD) 66 : ELSE 67 : READ(IOCHI1,520) (NAM(J)(1:12),J=1,NXD) 68 : ENDIF 69 : READ(IOCHI1,530) (ION(J),J=1,NXD) 70 : C 71 : C INITIALIZE NN 72 : C 73 : N3=0 74 : DO 100 L=1,6 75 : NN(L)=0 76 : 100 CONTINUE 77 : C 78 : C 79 : C INITIALIZE A 80 : 81 : DO 110 J=1,NXDIM 82 : DO 111 I=1,NYDIM 83 : AA(I,J)=0.D0 84 : 111 CONTINUE 85 : 110 CONTINUE 86 : 87 : 88 : C INPUT BASIS IN A MATRIX 89 : 90 : DO 200 I=1,NNN 91 : IDXT=IDX(I) 92 : IF(IDXT.GT.NXD)THEN 93 : INTERR(1)=IDXT 93 : CALL ERREUR(781) 94 : GO TO 500 95 : ENDIF 96 : CBRUNO 97 : NAME(I)=NAM(IDXT) 98 : NAMESP(I)=NAM(IDXT) 99 : IONZ(I)=ION(IDXT) 100 : IADXT(IDXT)=I 101 : IDY(I)=IDX(I) 102 : AA(I,I)=1.D0 103 : GK(I)=0.D0 104 : 200 CONTINUE 105 : 106 : NN(1)=NNN 107 : 108 : C ***************** LECTURE DES DONNEES THERMODYNAMIQUES 109 : C 110 : NXCMP=8 111 : SEGINI ITRAV 112 : I=NN(1) 113 : DO 400 L=2,6 114 : I0=I 115 : READ(IOCHI2,540) IN,MOCLE,NBCMP 116 : IF(MOCLE.EQ.'LIBRE')THEN 117 : LIBRE=.TRUE. 118 : NXCMP=NBCMP 119 : SEGADJ ITRAV 120 : ELSE 121 : LIBRE=.FALSE. 122 : NBCMP=8 123 : ENDIF 124 : IF(IN.EQ.0) GO TO 400 125 : DO 300 II=1,IN 126 : IF(LIBRE)THEN 127 : READ(IOCHI2,550) IDYT,GKT,(IDT(J),CIAT(J),J=1,4) 128 : J1=5 129 : IF(NBCMP.GT.8)THEN 130 : NBENR=(NBCMP-8)/4 131 : DO 40 JJ=1,NBENR 132 : J2=J1+3 133 : READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,J2) 134 : J1=J1+4 135 : 40 CONTINUE 136 : ENDIF 137 : READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,NBCMP), 138 : * LLXM,NAMLXM 139 : C WRITE(6,*) IDYT,GKT,(IDT(J),CIAT(J),J=1,NBCMP), 140 : C * LLXM,NAMLXM 141 : ELSE 142 : READ(IOCHI2,510) IDYT,GKT,(IDT(J),CIAT(J),J=1,8), 143 : * LLXM,NAMLXM 144 : ENDIF 145 : 146 : DO 310 J=1,8 147 : JTEST=IDT(J) 148 : IF(JTEST.EQ.0) GO TO 310 149 : IF(IADXT(JTEST).EQ.0) GO TO 300 150 : 310 CONTINUE 151 : 152 : I=I+1 153 : IF (I.GT.NYDIM)THEN 154 : MOTERR(1:8)=' CHMMX ' 155 : MOTERR(9:16)='SUITENTI' 155 : CALL ERREUR(787) 156 : RETURN 157 : ENDIF 158 : IDY(I)=IDYT 159 : GK(I)=GKT 160 : NAMESP(I)=NAMLXM 161 : DO 320 J=1,8 162 : JTEST=IDT(J) 163 : IF (IDT(J).EQ.90) N3=N3+1 164 : IF(JTEST.EQ.0) GO TO 320 165 : IADTJT=IADXT(JTEST) 166 : AA(I,IADTJT)=CIAT(J) 167 : 320 CONTINUE 168 : 300 CONTINUE 169 : 170 : 171 : *-----------------***------MONI------***------------------------------- 172 : * CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE 173 : * EN COMPTE; AVEC MINEQL IL EXISTE UNE FACON BIEN PLUS SIMPLE ET 174 : * AUSSI EFFICACE : 175 : * METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5 176 : * (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION), 177 : * EN TYPE 6 : 178 : * NN(6)=NN(5)+NN(6) 179 : * NN(5)=0 180 : * PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS : 181 : * EX: 182 : * I5=5 183 : * I6=6 183 : * CALL EXTYP(02231,I6,I5) 184 : ********************************************************************** 185 : 186 : NBT5=0 187 : IF (L.EQ.5) THEN 188 : IF(LXMX.EQ.0) GOTO 270 189 : MLXMX=LXMX 190 : SEGACT MLXMX 191 : NMXCH=MLXMX.LECT(/1) 192 : 193 : CPATBOS--------------------------------------------- 194 : C MISE EN IDP DES MINERAUX CHOISIS PAR L UTILISATEUR 195 : NPDIM=NMXCH 196 : SEGADJ IDSCHI 196 : CALL RSETI(IDP,MLXMX.LECT,NPDIM) 197 : IN5=I 198 : C ------- 199 : *C RECHERCHE DES MINERAUX NON PRIS EN COMPTE 200 : C ---- 201 : III=I 202 : DO 266 ICHOI=I0+1,III 203 : DO 267 NM0=1,NMXCH 204 : IF (IDY(ICHOI).EQ.MLXMX.LECT(NM0)) THEN 205 : NOUVI=NOUVI+1 206 : IDY(I0+NOUVI)=IDY(ICHOI) 207 : GK(I0+NOUVI)=GK(ICHOI) 208 : NAMESP(I0+NOUVI)=NAMESP(ICHOI) 209 : DO 220 JK=1,NNN 210 : AA(I0+NOUVI,JK)=AA(ICHOI,JK) 211 : 220 CONTINUE 212 : GOTO 265 213 : ENDIF 214 : 267 CONTINUE 215 : 216 : IDY(ICHOI)=0 217 : GK(ICHOI)=0.D0 218 : NAMESP(ICHOI)=' ' 219 : DO 210 JK=1,NNN 220 : AA(ICHOI,JK)=0.D0 221 : 210 CONTINUE 222 : 223 : I=I-1 224 : 265 CONTINUE 225 : 266 CONTINUE 226 : 227 : 228 : DO 275 LIK = I0+NMXCH+1,IN5 229 : IDY(LIK)=0 230 : DO 274 JIK=1,NNN 231 : AA(LIK,JIK)=0.D0 232 : 274 CONTINUE 233 : 275 CONTINUE 234 : * 235 : ENDIF 236 : * 237 : 270 CONTINUE 238 : 239 : 240 : NN(L)=I-I0 241 : 400 CONTINUE 242 : 243 : C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0 244 : IF(LXMX.NE.0)THEN 245 : SEGDES MLXMX 246 : ELSE 247 : NN123=NN(1)+NN(2)+NN(3)+1 248 : NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5) 249 : DO 600 N=NN123,NN45 250 : NPDIM=NPDIM+1 251 : SEGADJ IDSCHI 252 : IDP(NPDIM)=IDY(N) 253 : 600 CONTINUE 254 : ENDIF 255 : 256 : CMONI*************LE 1 MARS 91**************************************** 257 : IF (I.LT.NYDIM) THEN 258 : NYDIM=I 259 : SEGADJ IDSCHI 260 : ENDIF 261 : SEGSUP IZCOMP 262 : SEGSUP ITRAV 263 : CMONI***************************************************************** 264 : 510 FORMAT (I5,F9.3,4(I4,1F6.2),/,14X,4(I4,1F6.2),T57,I1,1X,A32) 265 : C 520 FORMAT((7X,A10,3(8X,A10))) 266 : C 520 FORMAT (4(8X,A8,2X)) 267 : 520 FORMAT(2X,4(6X,A12)) 268 : 540 FORMAT (I5,2X,A5,I5) 269 : * 270 : 530 FORMAT (40I2) 271 : 550 FORMAT (I5,F10.8,4(I5,1X,1F6.4)) 272 : 560 FORMAT (15X,4(I5,1X,1F6.4),T66,I1,1X,A22) 273 : 570 FORMAT (I5,3X,A12) 274 : 580 FORMAT (8X,A32) 275 : 590 FORMAT (I8,A32) 276 : 277 : C*****************REMISE EN TETE DES FICHIERS **************** 278 : 500 CONTINUE 279 : C REWIND(UNIT=IOCHI2) 280 : C CLOSE(UNIT=IOCHI2) 281 : C REWIND(UNIT=IOCHI1) 282 : C CLOSE(UNIT=IOCHI1) 283 : C******************************************************************* 284 : C WRITE(6,*) 'A LA SORTIE DE CHINPS , J= ',J 285 : 286 : RETURN 287 : END 288 : 289 : 290 : 291 : 292 : 293 : 294 : 295 : 296 : 297 : 298 :
© Cast3M 2003 - All rights reserved.
Disclaimer