C CHINPS SOURCE CHAT 05/01/12 21:57:51 5004 SUBROUTINE CHINPS(IDSCHI,LXMX,IOCHI1,IOCHI2) C C C======================================================================= C C C !!!ATTENTION! POUR LE CHOIX DES MINERAUX A CONSIDERER CF CHINP C ------------------------------------------------------------------ C ATTENTION| C SP DE LECTURE CORRESPONDANT A LA BASE DE DONNEES DE STRASBOURG C SOUS FORMAT MINEQL C et aux bases issues de CHESS utilisables par CASTEM C C C====================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMLENTI POINTEUR MLXMX.MLENTI -INC CCOPTIO CHARACTER*5 MOCLE CHARACTER*32 NAMLXM LOGICAL LIBRE SEGMENT IDSCHI REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) INTEGER IDECY(NYDIM),IONZ(NXDIM) CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) ENDSEGMENT C SEGMENT ITRAV REAL*8 CIAT(NXCMP) INTEGER IDT(NXCMP) ENDSEGMENT C SEGMENT IZCOMP CHARACTER*32 NAM(NXD) INTEGER ION(NXD),IADXT(NXD) ENDSEGMENT NXDIM=IDX(/1) NYDIM=IDY(/1) NZDIM=IDZ(/1) NPDIM=IDP(/1) LIBRE=.TRUE. READ(IOCHI1,590)NXD,NAMLXM IF(NAMLXM(1:10).NE.'COMPOSANTS')THEN NXD=200 BACKSPACE IOCHI1 LIBRE=.FALSE. ENDIF NNN=NXDIM NOUVI=0 SEGINI IZCOMP C INITIALIZE ADDRESS DO 20 J=1,NXD IADXT(J)=0 NAM(J)=' ' 20 CONTINUE C CBRUNO IF(LIBRE)THEN READ(IOCHI1,580) (NAM(J),J=1,NXD) ELSE READ(IOCHI1,520) (NAM(J)(1:12),J=1,NXD) ENDIF READ(IOCHI1,530) (ION(J),J=1,NXD) C C INITIALIZE NN C N3=0 DO 100 L=1,6 NN(L)=0 100 CONTINUE C C C INITIALIZE A DO 110 J=1,NXDIM DO 111 I=1,NYDIM AA(I,J)=0.D0 111 CONTINUE 110 CONTINUE C INPUT BASIS IN A MATRIX DO 200 I=1,NNN IDXT=IDX(I) IF(IDXT.GT.NXD)THEN INTERR(1)=IDXT CALL ERREUR(781) GO TO 500 ENDIF CBRUNO NAME(I)=NAM(IDXT) NAMESP(I)=NAM(IDXT) IONZ(I)=ION(IDXT) IADXT(IDXT)=I IDY(I)=IDX(I) AA(I,I)=1.D0 GK(I)=0.D0 200 CONTINUE NN(1)=NNN C ***************** LECTURE DES DONNEES THERMODYNAMIQUES C NXCMP=8 SEGINI ITRAV I=NN(1) DO 400 L=2,6 I0=I READ(IOCHI2,540) IN,MOCLE,NBCMP IF(MOCLE.EQ.'LIBRE')THEN LIBRE=.TRUE. NXCMP=NBCMP SEGADJ ITRAV ELSE LIBRE=.FALSE. NBCMP=8 ENDIF IF(IN.EQ.0) GO TO 400 DO 300 II=1,IN IF(LIBRE)THEN READ(IOCHI2,550) IDYT,GKT,(IDT(J),CIAT(J),J=1,4) J1=5 IF(NBCMP.GT.8)THEN NBENR=(NBCMP-8)/4 DO 40 JJ=1,NBENR J2=J1+3 READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,J2) J1=J1+4 40 CONTINUE ENDIF READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,NBCMP), * LLXM,NAMLXM C WRITE(6,*) IDYT,GKT,(IDT(J),CIAT(J),J=1,NBCMP), C * LLXM,NAMLXM ELSE READ(IOCHI2,510) IDYT,GKT,(IDT(J),CIAT(J),J=1,8), * LLXM,NAMLXM ENDIF DO 310 J=1,8 JTEST=IDT(J) IF(JTEST.EQ.0) GO TO 310 IF(IADXT(JTEST).EQ.0) GO TO 300 310 CONTINUE I=I+1 IF (I.GT.NYDIM)THEN MOTERR(1:8)=' CHMMX ' MOTERR(9:16)='SUITENTI' CALL ERREUR(787) RETURN ENDIF IDY(I)=IDYT GK(I)=GKT NAMESP(I)=NAMLXM DO 320 J=1,8 JTEST=IDT(J) IF (IDT(J).EQ.90) N3=N3+1 IF(JTEST.EQ.0) GO TO 320 IADTJT=IADXT(JTEST) AA(I,IADTJT)=CIAT(J) 320 CONTINUE 300 CONTINUE *-----------------***------MONI------***------------------------------- * CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE * EN COMPTE; AVEC MINEQL IL EXISTE UNE FACON BIEN PLUS SIMPLE ET * AUSSI EFFICACE : * METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5 * (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION), * EN TYPE 6 : * NN(6)=NN(5)+NN(6) * NN(5)=0 * PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS : * EX: * I5=5 * I6=6 * CALL EXTYP(02231,I6,I5) ********************************************************************** NBT5=0 IF (L.EQ.5) THEN IF(LXMX.EQ.0) GOTO 270 MLXMX=LXMX SEGACT MLXMX NMXCH=MLXMX.LECT(/1) CPATBOS--------------------------------------------- C MISE EN IDP DES MINERAUX CHOISIS PAR L UTILISATEUR NPDIM=NMXCH SEGADJ IDSCHI CALL RSETI(IDP,MLXMX.LECT,NPDIM) IN5=I C ------- *C RECHERCHE DES MINERAUX NON PRIS EN COMPTE C ---- III=I DO 266 ICHOI=I0+1,III DO 267 NM0=1,NMXCH IF (IDY(ICHOI).EQ.MLXMX.LECT(NM0)) THEN NOUVI=NOUVI+1 IDY(I0+NOUVI)=IDY(ICHOI) GK(I0+NOUVI)=GK(ICHOI) NAMESP(I0+NOUVI)=NAMESP(ICHOI) DO 220 JK=1,NNN AA(I0+NOUVI,JK)=AA(ICHOI,JK) 220 CONTINUE GOTO 265 ENDIF 267 CONTINUE IDY(ICHOI)=0 GK(ICHOI)=0.D0 NAMESP(ICHOI)=' ' DO 210 JK=1,NNN AA(ICHOI,JK)=0.D0 210 CONTINUE I=I-1 265 CONTINUE 266 CONTINUE DO 275 LIK = I0+NMXCH+1,IN5 IDY(LIK)=0 DO 274 JIK=1,NNN AA(LIK,JIK)=0.D0 274 CONTINUE 275 CONTINUE * ENDIF * 270 CONTINUE NN(L)=I-I0 400 CONTINUE C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0 IF(LXMX.NE.0)THEN SEGDES MLXMX ELSE NN123=NN(1)+NN(2)+NN(3)+1 NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5) DO 600 N=NN123,NN45 NPDIM=NPDIM+1 SEGADJ IDSCHI IDP(NPDIM)=IDY(N) 600 CONTINUE ENDIF CMONI*************LE 1 MARS 91**************************************** IF (I.LT.NYDIM) THEN NYDIM=I SEGADJ IDSCHI ENDIF SEGSUP IZCOMP SEGSUP ITRAV CMONI***************************************************************** 510 FORMAT (I5,F9.3,4(I4,1F6.2),/,14X,4(I4,1F6.2),T57,I1,1X,A32) C 520 FORMAT((7X,A10,3(8X,A10))) C 520 FORMAT (4(8X,A8,2X)) 520 FORMAT(2X,4(6X,A12)) 540 FORMAT (I5,2X,A5,I5) * 530 FORMAT (40I2) 550 FORMAT (I5,F10.8,4(I5,1X,1F6.4)) 560 FORMAT (15X,4(I5,1X,1F6.4),T66,I1,1X,A22) 570 FORMAT (I5,3X,A12) 580 FORMAT (8X,A32) 590 FORMAT (I8,A32) C*****************REMISE EN TETE DES FICHIERS **************** 500 CONTINUE C REWIND(UNIT=IOCHI2) C CLOSE(UNIT=IOCHI2) C REWIND(UNIT=IOCHI1) C CLOSE(UNIT=IOCHI1) C******************************************************************* C WRITE(6,*) 'A LA SORTIE DE CHINPS , J= ',J RETURN END