1 : C CHITPS SOURCE CHAT 05/01/12 21:58:27 5004 2 : SUBROUTINE CHITPS(IDSCHI,LGKTMP,IOCHI3) 3 : ************************************************************* 4 : * SP APPELE PAR CHIMI1 SI LE CALCUL N'EST PAS EFFECTUE A 5 : * TEMPERATURE CONSTANTE DE 25 øC, DANS LA CAS DE L'UTILISATION 6 : * DE LA BDD DE STRASBOURG 7 : *------------------------------------------------------------------- 8 : * SP ISSU DE TRIOEF 9 : * 10 : * CE SP SERT A LIRE LES DONNEES NECESSAIRES POUR CALCULER 11 : * ULTERIEUREMENT LES LOGK A LA TEMPERATURE TMPNEW 12 : * 13 : * LES DONNEES LUES PROVIENNENT DU FICHIER TLOGKS DATA (COMPULSION 14 : * DES FICHIERS AQUSPL DATA (ESP. AQ.) ET DU FICHIER CONTENU DANS 15 : * MON1904 MESSAGE (ESP. MIN.) ---> DU CENTRE DE GEOCHIMIE DE 16 : * STRASBOURG). 17 : * NOM = NOM DE L'ESPECE; 18 : * NUM = SON NUMERO DANS LE FICHIER DATA 19 : * NTV = LE NOMBRE DE TEMPERATURES STANDARD (0 25 60 100 150 200 20 : * 250 300) POUR LESQUELLES LE LOGK EST SENSE ET CONNU 21 : * TMIN = TEMP. STAND. MIN POUR LAQUELLE LE LOGK EST CONNU 22 : * TMAX = TEMP. STAND. MAX POUR LAQUELLE LE LOGK EST CONNU 23 : * XLGKLU(I),I=1,NT : VALEURS DU LOGK POUR CHACUNE DES TEMP.STAND. 24 : * VSPL(I),I=1,NT : VALEURS DES COEFF. DU POLYNOME NECESSAIRE 25 : * POUR LE CALCUL DU LOGK A LA TEMPNEW SOUHAITEE 26 : * 27 : * CE SP REMPLACE LE SP INPUTB DE MINEQL STANDARD 28 : * 29 : * CE TRAVAIL A ETE REALISE A PARTIR DES SP PROVENANT DU CENTRE 30 : * DE GEOCHIMIE DE LA SURFACE DE STRASBOURG 31 : * ---> CF MON1504 MESSAGE 32 : * 33 : ************************************************************* 34 : IMPLICIT INTEGER(I-N) 35 : IMPLICIT REAL*8 (A-H,O-Z) 36 : -INC CCOPTIO 37 : CHARACTER NOM*16 38 : CHARACTER NOMC*32 39 : LOGICAL LIBRE 40 : DIMENSION TEMPE0(8) 41 : SEGMENT ITRAV 42 : REAL*8 TEMPE(NT) 43 : ENDSEGMENT 44 : SEGMENT IDSCHI 45 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 46 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 47 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 48 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 49 : ENDSEGMENT 50 : SEGMENT LGKTMP 51 : INTEGER NUMT(NYDIM),NTVT(NYDIM) 52 : REAL*8 TMIMA(NYDIM,NT) 53 : REAL*8 POLYT(NYDIM,NT4),TGKLU(NYDIM,NT) 54 : ENDSEGMENT 55 : C 32=4*NT NT=8 56 : DIMENSION VSPL(32),XLGKLU(8) 57 : DATA TEMPE0/0.,25.,60.,100.,150.,200.,250.,300./ 58 : C 59 : NYDIM=IDY(/1) 60 : NT=8 61 : NT4=32 62 : N0=NN(1) 63 : N1A1=NN(1)+1 64 : N1A6=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+NN(6) 65 : 66 : READ(IOCHI3,500) NOM,II 67 : IF(NOM(1:5).EQ.'LIBRE')THEN 68 : LIBRE=.TRUE. 69 : NT=II 70 : NT4=II*4 71 : ELSE 72 : LIBRE=.FALSE. 73 : BACKSPACE IOCHI3 74 : ENDIF 75 : SEGINI ITRAV 76 : SEGINI LGKTMP 76 : CALL INITI(NTVT,NYDIM,0) 76 : CALL INITI(NUMT,NYDIM,0) 76 : CALL INITD(TMIMA,NYDIM*NT,0.D0) 76 : CALL INITD(POLYT,NYDIM*NT4,0.D0) 76 : CALL INITD(TGKLU,NYDIM*NT,0.D0) 77 : 30 CONTINUE 78 : IF(LIBRE)THEN 79 : READ(IOCHI3,502,END=80) NUM,NTV 80 : BACKSPACE IOCHI3 81 : NTV4=NTV 82 : JJ1=0 83 : NCC=0 84 : IF(NTV.GT.4)THEN 85 : NCC=(NTV-1)/4 86 : DO 15 JJ=1,NCC 87 : JJ1=4*(JJ-1) 88 : READ(IOCHI3,524)(TEMPE(II+JJ1),II=1,4) 89 : 15 CONTINUE 90 : NTV4= NTV-NCC*4 91 : JJ1=NCC*4 92 : ENDIF 93 : IF(NTV4.EQ.1)THEN 94 : READ(IOCHI3,521)(TEMPE(II+JJ1),II=1,NTV4),NOMC 95 : ELSEIF(NTV4.EQ.2)THEN 96 : READ(IOCHI3,522)(TEMPE(II+JJ1),II=1,NTV4),NOMC 97 : ELSEIF(NTV4.EQ.3)THEN 98 : READ(IOCHI3,523)(TEMPE(II+JJ1),II=1,NTV4),NOMC 99 : ELSEIF(NTV4.EQ.4)THEN 100 : READ(IOCHI3,524)(TEMPE(II+JJ1),II=1,NTV4),NOMC 101 : ENDIF 102 : READ(IOCHI3,525) (XLGKLU(II),II=1,NTV) 103 : ELSE 104 : READ(IOCHI3,500,END=80) NOM,NUM,NTV,TMIN,TMAX 105 : READ(IOCHI3,400) (XLGKLU(II),II=1,NT) 106 : DO 35 I=1,8 107 : IF(ABS(TEMPE0(I)-TMIN).LT.1.D-3)THEN 108 : II=I 109 : GO TO 40 110 : ENDIF 111 : 35 CONTINUE 112 : 40 CONTINUE 113 : DO 50 I=1,NTV 114 : TEMPE(I)=TEMPE0(II+I-1) 115 : 50 CONTINUE 116 : ENDIF 117 : IF (NTV.GT.2) THEN 118 : READ(IOCHI3,*) (VSPL(II),II=1,NT*4) 119 : ENDIF 120 : C 121 : DO 130 I=N1A1,N1A6 122 : IF(NUM.EQ.IDY(I)) THEN 123 : NTVT(I)=NTV 124 : NUMT(I)=NUM 125 : DO 140 J=1,NTV 126 : TGKLU(I,J)=XLGKLU(J) 127 : TMIMA(I,J)=TEMPE(J) 128 : 140 CONTINUE 129 : C 130 : C 131 : IF (NTV.GT.2) THEN 132 : DO 45 JJ=1,NT*4 133 : POLYT(I,JJ)=VSPL(JJ) 134 : 45 CONTINUE 135 : ENDIF 136 : GO TO 30 137 : ENDIF 138 : 130 CONTINUE 139 : GOTO 30 140 : 80 CONTINUE 141 : SEGSUP ITRAV 142 : C REWIND(UNIT=IOCHI3) 143 : C CLOSE(UNIT=IOCHI3) 144 : 400 FORMAT(10F8.3) 145 : 500 FORMAT(A16,I4,I5,2F10.3) 146 : 501 FORMAT(15X,I5,I5,2F10.3,1X,A32) 147 : 502 FORMAT(I5,I2) 148 : 521 FORMAT(7X,F10.3,31X,A32) 149 : 522 FORMAT(7X,2F10.3,21X,A32) 150 : 523 FORMAT(7X,3F10.3,11X,A32) 151 : 524 FORMAT(7X,4F10.3,1X,A32) 152 : 525 FORMAT(8F10.3) 153 : 526 FORMAT(4E16.6) 154 : RETURN 155 : END 156 : 157 : 158 : 159 : 160 : 161 : 162 :
© Cast3M 2003 - All rights reserved.
Disclaimer