C CHITPS SOURCE CHAT 05/01/12 21:58:27 5004 SUBROUTINE CHITPS(IDSCHI,LGKTMP,IOCHI3) ************************************************************* * SP APPELE PAR CHIMI1 SI LE CALCUL N'EST PAS EFFECTUE A * TEMPERATURE CONSTANTE DE 25 øC, DANS LA CAS DE L'UTILISATION * DE LA BDD DE STRASBOURG *------------------------------------------------------------------- * SP ISSU DE TRIOEF * * CE SP SERT A LIRE LES DONNEES NECESSAIRES POUR CALCULER * ULTERIEUREMENT LES LOGK A LA TEMPERATURE TMPNEW * * LES DONNEES LUES PROVIENNENT DU FICHIER TLOGKS DATA (COMPULSION * DES FICHIERS AQUSPL DATA (ESP. AQ.) ET DU FICHIER CONTENU DANS * MON1904 MESSAGE (ESP. MIN.) ---> DU CENTRE DE GEOCHIMIE DE * STRASBOURG). * NOM = NOM DE L'ESPECE; * NUM = SON NUMERO DANS LE FICHIER DATA * NTV = LE NOMBRE DE TEMPERATURES STANDARD (0 25 60 100 150 200 * 250 300) POUR LESQUELLES LE LOGK EST SENSE ET CONNU * TMIN = TEMP. STAND. MIN POUR LAQUELLE LE LOGK EST CONNU * TMAX = TEMP. STAND. MAX POUR LAQUELLE LE LOGK EST CONNU * XLGKLU(I),I=1,NT : VALEURS DU LOGK POUR CHACUNE DES TEMP.STAND. * VSPL(I),I=1,NT : VALEURS DES COEFF. DU POLYNOME NECESSAIRE * POUR LE CALCUL DU LOGK A LA TEMPNEW SOUHAITEE * * CE SP REMPLACE LE SP INPUTB DE MINEQL STANDARD * * CE TRAVAIL A ETE REALISE A PARTIR DES SP PROVENANT DU CENTRE * DE GEOCHIMIE DE LA SURFACE DE STRASBOURG * ---> CF MON1504 MESSAGE * ************************************************************* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO CHARACTER NOM*16 CHARACTER NOMC*32 LOGICAL LIBRE DIMENSION TEMPE0(8) SEGMENT ITRAV REAL*8 TEMPE(NT) ENDSEGMENT 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 LGKTMP INTEGER NUMT(NYDIM),NTVT(NYDIM) REAL*8 TMIMA(NYDIM,NT) REAL*8 POLYT(NYDIM,NT4),TGKLU(NYDIM,NT) ENDSEGMENT C 32=4*NT NT=8 DIMENSION VSPL(32),XLGKLU(8) DATA TEMPE0/0.,25.,60.,100.,150.,200.,250.,300./ C NYDIM=IDY(/1) NT=8 NT4=32 N0=NN(1) N1A1=NN(1)+1 N1A6=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+NN(6) READ(IOCHI3,500) NOM,II IF(NOM(1:5).EQ.'LIBRE')THEN LIBRE=.TRUE. NT=II NT4=II*4 ELSE LIBRE=.FALSE. BACKSPACE IOCHI3 ENDIF SEGINI ITRAV SEGINI LGKTMP CALL INITI(NTVT,NYDIM,0) CALL INITI(NUMT,NYDIM,0) CALL INITD(TMIMA,NYDIM*NT,0.D0) CALL INITD(POLYT,NYDIM*NT4,0.D0) CALL INITD(TGKLU,NYDIM*NT,0.D0) 30 CONTINUE IF(LIBRE)THEN READ(IOCHI3,502,END=80) NUM,NTV BACKSPACE IOCHI3 NTV4=NTV JJ1=0 NCC=0 IF(NTV.GT.4)THEN NCC=(NTV-1)/4 DO 15 JJ=1,NCC JJ1=4*(JJ-1) READ(IOCHI3,524)(TEMPE(II+JJ1),II=1,4) 15 CONTINUE NTV4= NTV-NCC*4 JJ1=NCC*4 ENDIF IF(NTV4.EQ.1)THEN READ(IOCHI3,521)(TEMPE(II+JJ1),II=1,NTV4),NOMC ELSEIF(NTV4.EQ.2)THEN READ(IOCHI3,522)(TEMPE(II+JJ1),II=1,NTV4),NOMC ELSEIF(NTV4.EQ.3)THEN READ(IOCHI3,523)(TEMPE(II+JJ1),II=1,NTV4),NOMC ELSEIF(NTV4.EQ.4)THEN READ(IOCHI3,524)(TEMPE(II+JJ1),II=1,NTV4),NOMC ENDIF READ(IOCHI3,525) (XLGKLU(II),II=1,NTV) ELSE READ(IOCHI3,500,END=80) NOM,NUM,NTV,TMIN,TMAX READ(IOCHI3,400) (XLGKLU(II),II=1,NT) DO 35 I=1,8 IF(ABS(TEMPE0(I)-TMIN).LT.1.D-3)THEN II=I GO TO 40 ENDIF 35 CONTINUE 40 CONTINUE DO 50 I=1,NTV TEMPE(I)=TEMPE0(II+I-1) 50 CONTINUE ENDIF IF (NTV.GT.2) THEN READ(IOCHI3,*) (VSPL(II),II=1,NT*4) ENDIF C DO 130 I=N1A1,N1A6 IF(NUM.EQ.IDY(I)) THEN NTVT(I)=NTV NUMT(I)=NUM DO 140 J=1,NTV TGKLU(I,J)=XLGKLU(J) TMIMA(I,J)=TEMPE(J) 140 CONTINUE C C IF (NTV.GT.2) THEN DO 45 JJ=1,NT*4 POLYT(I,JJ)=VSPL(JJ) 45 CONTINUE ENDIF GO TO 30 ENDIF 130 CONTINUE GOTO 30 80 CONTINUE SEGSUP ITRAV C REWIND(UNIT=IOCHI3) C CLOSE(UNIT=IOCHI3) 400 FORMAT(10F8.3) 500 FORMAT(A16,I4,I5,2F10.3) 501 FORMAT(15X,I5,I5,2F10.3,1X,A32) 502 FORMAT(I5,I2) 521 FORMAT(7X,F10.3,31X,A32) 522 FORMAT(7X,2F10.3,21X,A32) 523 FORMAT(7X,3F10.3,11X,A32) 524 FORMAT(7X,4F10.3,1X,A32) 525 FORMAT(8F10.3) 526 FORMAT(4E16.6) RETURN END