Sources Esope | Cast3M

chitps
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