C CHINPS SOURCE OF166741 23/10/16 21:15:05 11754 SUBROUTINE CHINPS(IDSCHI,LXMX,IOCHI1,IOCHI2) 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====================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMLENTI POINTEUR MLXMX.MLENTI 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 SEGMENT ITRAV REAL*8 CIAT(NXCMP) INTEGER IDT(NXCMP) ENDSEGMENT SEGMENT IZCOMP CHARACTER*32 NAM(NXD) INTEGER ION(NXD),IADXT(NXD) ENDSEGMENT CHARACTER*5 MOCLE CHARACTER*32 NAMLXM LOGICAL LIBRE NXDIM=IDX(/1) NYDIM=IDY(/1) NZDIM=IDZ(/1) NPDIM=IDP(/1) NNN=NXDIM NOUVI=0 LIBRE=.TRUE. READ(IOCHI1,590)NXD,NAMLXM IF(NAMLXM(1:10).NE.'COMPOSANTS')THEN NXD=200 BACKSPACE IOCHI1 LIBRE=.FALSE. ENDIF SEGINI IZCOMP C INITIALIZE ADDRESS DO J=1,NXD NAM(J) =' ' ION(J) =0 IADXT(J)=0 ENDDO 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 INITIALIZE NN N3=0 NN(1)=0 NN(2)=0 NN(3)=0 NN(4)=0 NN(5)=0 NN(6)=0 C INITIALIZE A DO J=1,NXDIM DO I=1,NYDIM AA(I,J)=0.D0 ENDDO ENDDO C INPUT BASIS IN A MATRIX DO 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 ENDDO NN(1)=NNN C ***************** LECTURE DES DONNEES THERMODYNAMIQUES 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(ioimp,*) 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 J=1,8 JTEST=IDT(J) IF (JTEST.NE.0) THEN IF (JTEST.EQ.90) N3=N3+1 IADTJT=IADXT(JTEST) AA(I,IADTJT)=CIAT(J) ENDIF ENDDO 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 JK=1,NNN AA(I0+NOUVI,JK)=AA(ICHOI,JK) ENDDO GOTO 265 ENDIF 267 CONTINUE IDY(ICHOI)=0 GK(ICHOI)=0.D0 NAMESP(ICHOI)=' ' DO JK=1,NNN AA(ICHOI,JK)=0.D0 ENDDO I=I-1 265 CONTINUE 266 CONTINUE DO LIK = I0+NMXCH+1,IN5 IDY(LIK)=0 DO JIK=1,NNN AA(LIK,JIK)=0.D0 ENDDO ENDDO 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 N=NN123,NN45 NPDIM=NPDIM+1 SEGADJ IDSCHI IDP(NPDIM)=IDY(N) ENDDO 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)) 530 FORMAT (40I2) 540 FORMAT (I5,2X,A5,I5) 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(IOIMP,*) 'A LA SORTIE DE CHINPS , J= ',J RETURN END