寻找chemkin2!

linzy96

chemkin系列中只有chemkin2是代码公开的。但是当时对中国是禁运的。
不知道那位收集了他没有？如能共享正是万分感谢啊。

sunmoon

2版源码在江湖已经绝迹，有人有，但不会轻易给的，它的珍贵是4.0版难比的。

linzy96

看来没希望找到了？
真是踏破铁鞋难找到啦

rhong

我在1998年,在美国UMass大学时使用的就是2版源码,
目前还在使用.
Have fun!:
PROGRAM CKINTP
     IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     PARAMETER (MDIM=10, KDIM=155, MKDIM=MDIM*KDIM, IDIM=1030, LSYM=16,
    1           NPAR=3, NPIDIM=IDIM*NPAR, NPC=5, NPCP2=NPC+2, MAXTP=3,
    2           NTR=MAXTP-1, NKTDIM=NTR*NPCP2*KDIM, MAXSP=6, MAXTB=10,
    3           NLAR=2, NSIDIM=MAXSP*IDIM, NTIDIM=MAXTB*IDIM,
    4           NLIDIM=NLAR*IDIM, NFAR=8, NFIDIM=NFAR*IDIM,
    5           NTDIM=KDIM*MAXTP, NIDIM=11*IDIM, LIN=15, LOUT=16,
    6           LTHRM=17, LINC=25, CKMIN=1.0E-3, MAXORD=KDIM,
    7           NOIDIM=MAXORD*IDIM)
C
     CHARACTER KNAME(KDIM)*(LSYM), ENAME(MDIM)*(LSYM), SUB(80)*80,
    1          KEY(5)*4, LINE*80, IUNITS*80, AUNITS*4, EUNITS*4,
    2          UPCASE*4, VERS*(LSYM), PREC*(LSYM)
C
     DIMENSION AWT(MDIM), KNCF(MDIM,KDIM), WTM(KDIM), KPHSE(KDIM),
    1          KCHRG(KDIM), A(NPCP2,NTR,KDIM), T(MAXTP,KDIM), NT(KDIM),
    2          NSPEC(IDIM), NREAC(IDIM), NU(MAXSP,IDIM),
    3          NUNK(MAXSP,IDIM), PAR(NPAR,IDIM), IDUP(IDIM),IREV(IDIM),
    4          RPAR(NPAR,IDIM), ILAN(IDIM), PLAN(NLAR,IDIM),
    5          IRLT(IDIM), RLAN(NLAR,IDIM), IWL(IDIM),  WL(IDIM),
    6          IFAL(IDIM), IFOP(IDIM), KFAL(IDIM), PFAL(NFAR,IDIM),
    7          ITHB(IDIM),NTBS(IDIM),AIK(MAXTB,IDIM),NKTB(MAXTB,IDIM),
    8          IRNU(IDIM), RNU(MAXSP,IDIM), IORD(IDIM),
    9          KORD(MAXORD,IDIM), RORD(MAXORD,IDIM)
     DIMENSION value(5)
C
     LOGICAL KERR, THERMO, ITHRM(KDIM)
C
     PARAMETER (NJAR=9, NF1R=4, NJIDIM=NJAR*IDIM, NF1IDIM=NF1R*IDIM)
     DIMENSION IEIM(IDIM), ITDEP(IDIM), IJAN(IDIM), PJAN(NJAR,IDIM),
    1          IFT1(IDIM), PFT1(NF1R,IDIM), IEXC(IDIM), PEXC(IDIM)
     DATA NEIM,NJAN,NFT1,NEXC/4*0/, IEIM/IDIM*0/, ITDEP/IDIM*0/,
    1     IJAN/IDIM*0/, IFT1/IDIM*0/, PJAN/NJIDIM*0.0/,
    2     PFT1/NF1IDIM*0.0/, PEXC/IDIM*0.0/
C
C     Initialize variables
C
     DATA KEY/';ELEM';,';SPEC';,';THER';,';REAC';,';END';/, KERR/.FALSE./,
    1     ITASK,NCHRG,MM,KK,II,NLAN,NFAL,NTHB,NREV,NRLT,NWL,
    *     NRNU,NORD/13*0/,
    2     ENAME,AWT/MDIM*'; ';,MDIM*0.0/, THERMO/.TRUE./,
    3     T/NTDIM*-1.0/, KNAME,WTM,NT,KPHSE,KCHRG,ITHRM
    4     /KDIM*'; ';, KDIM*0.0, KDIM*3, KDIM*0, KDIM*0, KDIM*.FALSE./,
    5     WL,IFOP,NTBS,IDUP /IDIM*0.0, IDIM*-1, IDIM*0, IDIM*0/,
    6     NSPEC,NREAC,IREV,ILAN,IRLT,IWL,IFAL,KFAL,ITHB,IRNU,IORD
    7     /NIDIM*0/
C
     DATA NUNK,NU/NSIDIM*0, NSIDIM*0/, NKTB,AIK/NTIDIM*0,NTIDIM*-1.0/
     DATA RNU/NSIDIM*0.0/, KORD/NOIDIM*0/, RORD/NOIDIM*0.0/
     DATA PAR,RPAR/NPIDIM*0.0, NPIDIM*0.0/
     DATA PLAN,RLAN/NLIDIM*0.0, NLIDIM*0.0/
     DATA PFAL/NFIDIM*0.0/, KNCF/MKDIM*0.0/, A/NKTDIM*0.0/
C----------------------------------------------------------------------C
C
     OPEN (LOUT, form=';formATTED';, STATUS=';UNKNOWN';, FILE=';chem.out';)
C
     VERS = ';3.9';
     WRITE  (LOUT, 15) VERS(:4)
  15 formAT (/
    1'; CHEMKIN INTERPRETER OUTPUT: CHEMKIN-II Version ';,A,'; Aug. 1994';
C*****precision > double
    2/';                              DOUBLE PRECISION';/)
     PREC = ';DOUBLE';
     OPEN (LIN, form=';formATTED';, STATUS=';OLD';, FILE=';chem.inp';,
    1      ERR=11111)
     READ (LIN,';(A)';,END=11111)
     REWIND (LIN)
100 CONTINUE
     LINE = '; ';
     READ (LIN,';(A)';,END=5000) LINE
105 CONTINUE
     ILEN = IPPLEN(LINE)
     IF (ILEN .EQ. 0) GO TO 100
C
     CALL CKISUB (LINE(:ILEN), SUB, NSUB)
C
C        IS THERE A KEYWORD?
C
     CALL CKCOMP ( UPCASE(SUB(1), 4) , KEY, 5, NKEY)
     IF (NKEY .GT. 0) ITASK = 0
C
     IF (NKEY.EQ.1 .OR. NKEY.EQ.2) THEN
C
C        ELEMENT OR SPECIES DATA
C
        ITASK = NKEY
        IF (NSUB .EQ. 1) GO TO 100
C
        DO 25 N = 2, NSUB
           SUB(N-1) = '; ';
           SUB(N-1) = SUB(N)
  25    CONTINUE
        NSUB = NSUB-1
C
     ELSEIF (NKEY .EQ. 3) THEN
C
C        THERMODYNAMIC DATA
C
        IF (NSUB .GT. 1) THEN
           IF ( UPCASE(SUB(2), 3) .EQ. ';ALL';) THEN
              THERMO = .FALSE.
              READ (LIN,';(A)';) LINE
              CALL IPPARR (LINE, -1, 3, value, NVAL, IER, LOUT)
              IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
                 KERR = .TRUE.
                 WRITE (LOUT, 333)
              ELSE
                 TLO = value(1)
                 TMID = value(2)
                 THI = value(3)
              ENDIF
           ENDIF
        ELSE
C
C           USE THERMODYNAMIC DATABASE FOR DEFAULT TLO,TMID,THI
           OPEN (LTHRM, form=';formATTED';, STATUS=';OLD';,
    1                   FILE=';therm.dat';, ERR=22222)
C
311       CONTINUE
           READ (LTHRM,';(A)';,END=22222) LINE
           IF (IPPLEN(LINE).LE.0 .OR. INDEX(LINE,';THERMO';).GT.0
    1          .OR. INDEX(LINE,';thermo';).GT.0) GO TO 311
C
           CALL IPPARR (LINE, -1, 3, value, NVAL, IER, LOUT)
           IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
              KERR = .TRUE.
              WRITE (LOUT, 333)
           ELSE
              TLO = value(1)
              TMID = value(2)
              THI = value(3)
           ENDIF
           CLOSE (LTHRM)
        ENDIF
C
        CALL CKTHRM (LIN, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
    1                KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
    2                THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
C
        IF (.NOT. THERMO)
    1      CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
    2                   KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
    3                   LOUT, KERR)
        I1 = IFIRCH(LINE)
        IF (UPCASE(LINE(I1, 4) .EQ. ';REAC';) GO TO 105
C
     ELSEIF (NKEY .EQ. 4) THEN
C
        ITASK = 4
C        START OF REACTIONS; ARE UNITS SPECIFIED?
        CALL CKUNIT (LINE(:ILEN), AUNITS, EUNITS, IUNITS)
C
        IF (THERMO) THEN
C
C           THERMODYNAMIC DATA
           OPEN (LTHRM, form=';formATTED';, STATUS=';OLD';,
    1                   FILE=';therm.dat';, ERR=22222)
312       CONTINUE
           READ (LTHRM,';(A)';,END=22222) LINE
           IF (IPPLEN(LINE).LE.0 .OR. INDEX(LINE,';THERM';).GT.0
    1          .OR. INDEX(LINE,';therm';).GT.0) GO TO 312
C
           CALL IPPARR (LINE, -1, 3, value, NVAL, IER, LOUT)
           IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
              KERR = .TRUE.
              WRITE (LOUT, 333)
           ELSE
              TLO = value(1)
              TMID = value(2)
              THI = value(3)
           ENDIF
           CALL CKTHRM (LTHRM, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
    1                   KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
    2                   THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
           CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
    1                   KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
    2                   LOUT, KERR)
           THERMO = .FALSE.
           CLOSE (LTHRM)
        ENDIF
C
        WRITE (LOUT, 1800)
        GO TO 100
     ENDIF
C
     IF (ITASK .EQ. 1) THEN
C
C        ELEMENT DATA
C
        IF (MM .EQ. 0) THEN
           WRITE (LOUT, 200)
           WRITE (LOUT, 300)
           WRITE (LOUT, 200)
        ENDIF
C
        IF (NSUB .GT. 0) THEN
           M1 = MM +1
           CALL CKCHAR (SUB, NSUB, MDIM, ENAME, AWT, MM, KERR, LOUT)
           DO 110 M = M1, MM
              IF (AWT(M) .LE. 0) CALL CKAWTM (ENAME(M), AWT(M))
              WRITE (LOUT, 400) M,ENAME(M)(:4),AWT(M)
              IF (AWT(M) .LE. 0) THEN
                 KERR = .TRUE.
                 WRITE (LOUT, 1000) ENAME(M)
              ENDIF
110       CONTINUE
        ENDIF
C
     ELSEIF (ITASK .EQ. 2) THEN
C
C        PROCESS SPECIES DATA
C
        IF (KK .EQ. 0) WRITE (LOUT, 200)
        IF (NSUB .GT. 0)
    1   CALL CKCHAR (SUB, NSUB, KDIM, KNAME, WTM, KK, KERR, LOUT)
C
     ELSEIF (ITASK .EQ. 4) THEN
C
C        PROCESS REACTION DATA
C
        IND = 0
        DO 120 N = 1, NSUB
           IND = MAX(IND, INDEX(SUB(N),';/';))
           IF (UPCASE(SUB(N), 3) .EQ. ';DUP';) IND = MAX(IND,1)
120    CONTINUE
        IF (IND .GT. 0) THEN
C
C           AUXILIARY REACTION DATA
C
           CALL CKAUXL (SUB, NSUB, II, KK, KNAME, LOUT, MAXSP, NPAR,
    1                   NSPEC, NTHB, ITHB, NTBS, MAXTB, NKTB, AIK,
    2                   NFAL, IFAL, IDUP, NFAR, PFAL, IFOP, NLAN,
    3                   ILAN, NLAR, PLAN, NREV, IREV, RPAR, NRLT, IRLT,
    4                   RLAN, NWL, IWL, WL, KERR, NORD, IORD, MAXORD,
    5                   KORD, RORD, NUNK, NU, NRNU, IRNU, RNU,
    6                   NEIM, IEIM, ITDEP, NJAN, IJAN, NJAR, PJAN,
    7                   NFT1, IFT1, NF1R, PFT1, NEXC, IEXC, PEXC)
C
        ELSE
C
C           THIS IS A REACTION STRING
C
           IF (II .LT. IDIM) THEN
C
              IF (II .GT. 0)
C
C              CHECK PREVIOUS REACTION FOR COMPLETENESS
C
    1         CALL CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR,
    2                      AUNITS, EUNITS, NREAC, NUNK, NU, KCHRG,
    3                      MDIM, MM, KNCF, IDUP, NFAL, IFAL, KFAL,
    4                      NFAR, PFAL, IFOP, NREV, IREV, NTHB, ITHB,
    5                      NLAN, ILAN, NRLT, IRLT, KERR, LOUT, NRNU,
    6                      IRNU, RNU, CKMIN)
C
C              NEW REACTION
C
              II = II+1
              CALL CKREAC (LINE(:ILEN), II, KK, KNAME, LOUT, MAXSP,
    1                      NSPEC, NREAC, NUNK, NU, NPAR, PAR,
    2                      NTHB, ITHB, NFAL, IFAL, KFAL, NWL,
    3                      IWL, WL, NRNU, IRNU, RNU, KERR)
C
           ELSE
              WRITE (LOUT, 1070)
              KERR = .TRUE.
           ENDIF
C
        ENDIF
     ENDIF
     GO TO 100
C
5000 CONTINUE
     IF (II .GT. 0) THEN
         CALL CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR, AUNITS,
    1                 EUNITS, NREAC, NUNK, NU, KCHRG, MDIM, MM,
    2                 KNCF, IDUP, NFAL, IFAL, KFAL, NFAR, PFAL, IFOP,
    3                 NREV, IREV, NTHB, ITHB, NLAN, ILAN, NRLT,
    4                 IRLT, KERR, LOUT, NRNU, IRNU, RNU, CKMIN)
        DO 500 I = 1, II
           IF (IDUP(I) .LT. 0) THEN
              KERR = .TRUE.
              WRITE (LOUT, 1095) I
           ENDIF
500    CONTINUE
C
        WRITE (LOUT, ';(/1X,A)';) '; NOTE: ';//IUNITS(:ILASCH(IUNITS))
C
     ELSEIF (THERMO) THEN
        OPEN (LTHRM, form=';formATTED';, STATUS=';OLD';,
    1                FILE=';therm.dat';, ERR=22222)
C
313    CONTINUE
        READ (LTHRM,';(A)';,END=22222) LINE
        IF (IPPLEN(LINE).LE.0 .OR. INDEX(LINE,';THERM';).GT.0
    1       .OR. INDEX(LINE,';therm';).GT.0) GO TO 313
C
        CALL IPPARR (LINE, -1, 3, value, NVAL, IER, LOUT)
        IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
           KERR = .TRUE.
           WRITE (LOUT, 333)
        ELSE
           TLO = value(1)
           TMID = value(2)
           THI = value(3)
        ENDIF
        CALL CKTHRM (LTHRM, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
    1                KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
    2                THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
        CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
    1                KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
    2                LOUT, KERR)
        CLOSE  (LTHRM)
     ENDIF
C
     CLOSE (LIN)
     OPEN (LINC, form=';UNformATTED';, STATUS=';UNKNOWN';,
    1            FILE=';chem.bin';)
     WRITE (LINC) VERS, PREC, KERR
C
     IF (KERR) THEN
        WRITE (LOUT, ';(//A)';)
    1   '; WARNING...THERE IS AN ERROR IN THE LINKING FILE';
        CLOSE (LINC)
        CLOSE (LOUT)
        STOP
     ENDIF
C
     DO 1150 K = 1, KK
        IF (KCHRG(K) .NE. 0) NCHRG = NCHRG+1
1150 CONTINUE
C
     LENICK = 1 + (3 + MM)*KK + (2 + 2*MAXSP)*II + NLAN + NRLT
    1           + 3*NFAL + (2 + MAXTB)*NTHB + NREV + NWL + NRNU
    2           + NORD*(1 + MAXORD) + 2*NEIM + NJAN + NFT1
    3           + NEXC
C
     LENCCK = MM + KK
C
     LENRCK = 3 + MM + KK*(5 + MAXTP + NTR*NPCP2) + II*7 + NREV
    1           + NPAR*(II + NREV) + NLAR*(NLAN + NRLT)
    2           + NFAR*NFAL + MAXTB*NTHB + NWL + NRNU*MAXSP
    3           + NORD*MAXORD + NJAR*NJAN + NF1R*NFT1 + NEXC
C
     WRITE (LINC) LENICK, LENRCK, LENCCK, MM, KK, II, MAXSP,
    1             MAXTB, MAXTP, NPC, NPAR, NLAR, NFAR, NREV, NFAL,
    2             NTHB, NLAN, NRLT, NWL, NCHRG, NEIM, NJAR, NJAN,
    3             NF1R, NFT1, NEXC, NRNU, NORD, MAXORD, CKMIN
     WRITE (LINC) (ENAME(M), AWT(M), M = 1, MM)
     WRITE (LINC) (KNAME(K), (KNCF(M,K),M=1,MM), KPHSE(K),
    1              KCHRG(K), WTM(K), NT(K), (T(L,K),L=1,MAXTP),
    2              ((A(M,L,K), M=1,NPCP2), L=1,NTR), K = 1, KK)
C
     IF (II .GT. 0) THEN
C
        WRITE (LINC) (NSPEC(I), NREAC(I), (PAR(N,I), N = 1, NPAR),
    1         (NU(M,I), NUNK(M,I), M = 1, MAXSP), I = 1, II)
C
        IF (NREV .GT. 0) WRITE (LINC)
    1      (IREV(N),(RPAR(L,N),L=1,NPAR),N=1,NREV)
C
        IF (NFAL .GT. 0) WRITE (LINC)
    1      (IFAL(N),IFOP(N),KFAL(N),(PFAL(L,N),L=1,NFAR), N = 1, NFAL)
C
        IF (NTHB .GT. 0) WRITE (LINC)
    1      (ITHB(N),NTBS(N),(NKTB(M,N),AIK(M,N),M=1,MAXTB),N=1,NTHB)
C
        IF (NLAN .GT. 0) WRITE (LINC)
    1      (ILAN(N), (PLAN(L,N), L = 1, NLAR), N = 1, NLAN)
C
        IF (NRLT .GT. 0) WRITE (LINC)
    1      (IRLT(N), (RLAN(L,N), L = 1, NLAR), N=1,NRLT)
C
        IF (NWL .GT. 0) WRITE (LINC) (IWL(N), WL(N), N = 1, NWL)
C
        IF (NEIM .GT. 0) WRITE (LINC) (IEIM(N),ITDEP(N),N=1,NEIM)
C
        IF (NJAN .GT. 0) WRITE (LINC)
    1      (IJAN(N), (PJAN(L,N), L = 1, NJAR), N = 1, NJAN)
C
        IF (NFT1 .GT. 0) WRITE (LINC)
    1      (IFT1(N), (PFT1(L,N), L = 1, NF1R), N = 1, NFT1)
C
        IF (NEXC .GT. 0) WRITE (LINC)
    1      (IEXC(N), PEXC(N), N=1, NEXC)
        IF (NRNU .GT. 0) WRITE (LINC)
    1      (IRNU(N), (RNU(M,N), M = 1, MAXSP), N = 1, NRNU)
        IF (NORD .GT. 0) WRITE (LINC)
    1      (IORD(N), (KORD(L,N), RORD(L,N), L=1, MAXORD), N=1,NORD)
     ELSE
        WRITE (LOUT, ';(/A)';)
    1      '; WARNING...NO REACTION INPUT FOUND; ';,
    2      '; LINKING FILE HAS NO REACTION INformATION ON IT.';
     ENDIF
C
     WRITE (LOUT, ';(///A)';)
    1   '; NO ERRORS FOUND ON INPUT...CHEMKIN LINKING FILE WRITTEN.';
C
     WRITE (LOUT, ';(/A,3(/A,I6))';)
    1      '; WORKING SPACE REQUIREMENTS ARE';,
    2      ';    INTEGER:   ';,LENICK,
    3      ';    REAL:      ';,LENRCK,
    4      ';    CHARACTER: ';,LENCCK
     CLOSE (LINC)
     CLOSE (LOUT)
     STOP
11111 CONTINUE
     WRITE (LOUT,*) '; Error...cannot read chem.inp...';
     CLOSE (LIN)
     STOP 2
22222 CONTINUE
     WRITE (LOUT,*) '; Error...cannot read therm.dat...';
     CLOSE (LTHRM)
     STOP 2
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKCHAR (SUB, NSUB, NDIM, STRAY, RAY, NN, KERR, LOUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION RAY(*), PAR(1)
     CHARACTER*(*) SUB(*), STRAY(*)
     CHARACTER ISTR*80, UPCASE*4
     LOGICAL KERR
C
     ILEN = LEN(STRAY(1))
C
     DO 200 N = 1, NSUB
        IF ( UPCASE(SUB(N), 3) .EQ. ';END';) RETURN
        ISTR = '; ';
        I1 = INDEX(SUB(N),';/';)
        IF (I1 .EQ .1) THEN
           KERR = .TRUE.
           WRITE (LOUT, 130) SUB(N)(:ILASCH(SUB(N)))
        ELSE
           IF (I1 .LE. 0) THEN
              ISTR = SUB(N)
           ELSE
              ISTR = SUB(N)(:I1-1)
           ENDIF
           CALL CKCOMP (ISTR, STRAY, NN, INUM)
C
           IF (INUM .GT. 0) THEN
              WRITE (LOUT, 100) SUB(N)(:ILASCH(SUB(N)))
           ELSE
              IF (NN .LT. NDIM) THEN
                 IF (ISTR(ILEN+1 .NE. '; ';) THEN
                    WRITE (LOUT, 120) SUB(N)(:ILASCH(SUB(N)))
                    KERR = .TRUE.
                 ELSE
                    NN = NN + 1
                    STRAY(NN) = '; ';
                    STRAY(NN) = ISTR(:ILEN)
                    IF (I1 .GT. 0) THEN
                       I2 = I1 + INDEX(SUB(N)(I1+1,';/';)
                       ISTR = '; ';
                       ISTR = SUB(N)(I1+1:I2-1)
                       CALL IPPARR (ISTR, 1, 1, PAR, NVAL, IER, LOUT)
                       KERR = KERR .OR. (IER.NE.0)
                       RAY(NN) = PAR(1)
                    ENDIF
                 ENDIF
              ELSE
                 WRITE (LOUT, 110) SUB(N)(:ILASCH(SUB(N)))
                 KERR = .TRUE.
              ENDIF
           ENDIF
        ENDIF
200 CONTINUE
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKAWTM (ENAME, AWT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     PARAMETER (NATOM = 102)
     DIMENSION ATOM(NATOM)
     CHARACTER*(*) ENAME
     CHARACTER*2 IATOM(NATOM), UPCASE
C
     DATA (IATOM(I),ATOM(I),I=1,40) /
    *';H ';,  1.00797, ';HE';,  4.00260, ';LI';,  6.93900, ';BE';,  9.01220,
    *';B ';, 10.81100, ';C ';, 12.01115, ';N ';, 14.00670, ';O ';, 15.99940,
    *';F ';, 18.99840, ';NE';, 20.18300, ';NA';, 22.98980, ';MG';, 24.31200,
    *';AL';, 26.98150, ';SI';, 28.08600, ' ';, 30.97380, ';S ';, 32.06400,
    *';CL';, 35.45300, ';AR';, 39.94800, ';K ';, 39.10200, ';CA';, 40.08000,
    *';SC';, 44.95600, ';TI';, 47.90000, ';V ';, 50.94200, ';CR';, 51.99600,
    *';MN';, 54.93800, ';FE';, 55.84700, ';CO';, 58.93320, ';NI';, 58.71000,
    *';CU';, 63.54000, ';ZN';, 65.37000, ';GA';, 69.72000, ';GE';, 72.59000,
    *';AS';, 74.92160, ';SE';, 78.96000, ';BR';, 79.90090, ';KR';, 83.80000,
    *';RB';, 85.47000, ';SR';, 87.62000, ';Y ';, 88.90500, ';ZR';, 91.22000/
C
     DATA (IATOM(I),ATOM(I),I=41,80) /
    *';NB';, 92.90600, ';MO';, 95.94000, ';TC';, 99.00000, ';RU';,101.07000,
    *';RH';,102.90500, 'D';,106.40000, ';AG';,107.87000, ';CD';,112.40000,
    *';IN';,114.82000, ';SN';,118.69000, ';SB';,121.75000, ';TE';,127.60000,
    *';I ';,126.90440, ';XE';,131.30000, ';CS';,132.90500, ';BA';,137.34000,
    *';LA';,138.91000, ';CE';,140.12000, 'R';,140.90700, ';ND';,144.24000,
    *';PM';,145.00000, ';SM';,150.35000, ';EU';,151.96000, ';GD';,157.25000,
    *';TB';,158.92400, ';DY';,162.50000, ';HO';,164.93000, ';ER';,167.26000,
    *';TM';,168.93400, ';YB';,173.04000, ';LU';,174.99700, ';HF';,178.49000,
    *';TA';,180.94800, ';W ';,183.85000, ';RE';,186.20000, ';OS';,190.20000,
    *';IR';,192.20000, ';PT';,195.09000, ';AU';,196.96700, ';HG';,200.59000/
C
     DATA (IATOM(I),ATOM(I),I=81,NATOM) /
    *';TL';,204.37000, ';PB';,207.19000, ';BI';,208.98000, ';PO';,210.00000,
    *';AT';,210.00000, ';RN';,222.00000, ';FR';,223.00000, ';RA';,226.00000,
    *';AC';,227.00000, ';TH';,232.03800, ';PA';,231.00000, ';U ';,238.03000,
    *';NP';,237.00000, ';PU';,242.00000, ';AM';,243.00000, ';CM';,247.00000,
    *';BK';,249.00000, ';CF';,251.00000, ';ES';,254.00000, ';FM';,253.00000,
    *';D ';,002.01410, ';E';,5.45E-4/
C
     CALL CKCOMP ( UPCASE(ENAME, 2), IATOM, NATOM, L)
     IF (L .GT. 0) AWT = ATOM(L)
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKTHRM (LUNIT, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
    1                   KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
    2                   THI, T, NPCP2, A, ITHRM, KERR, LOUT, ISTR)
     DIMENSION WTM(*), NT(*), T(MAXTP,*), KPHSE(*), KNCF(MDIM,*),
    1          KCHRG(*), A(NPCP2,NTR,*), AWT(*), value(5)
     CHARACTER*(*) ENAME(*), KNAME(*)
     CHARACTER*80 ISTR, SUB(80), LINE(4)
     CHARACTER ELEM*16, UPCASE*4
     LOGICAL KERR, ITHRM(*)
C
     IF (MM.LE.0 .OR. KK.LE.0) WRITE (LOUT, 80)
C
     GO TO 20
  10 CONTINUE
     ISTR = '; ';
     READ (LUNIT,';(A)';,END=40) ISTR
  20 CONTINUE
     ILEN = IPPLEN(ISTR)
     IF (ILEN .LE. 0) GO TO 10
C
     CALL CKISUB (ISTR(:ILEN), SUB, NSUB)
     IF (UPCASE(SUB(1), 3) .EQ. ';END'; .OR.
    1    UPCASE(SUB(1), 4) .EQ. ';REAC';) RETURN
C
     IF (ILEN.LT.80 .OR. ISTR(80:80).NE.';1';) GO TO 10
     CALL CKCOMP (SUB(1), KNAME, KK, K)
C
     IF (K.LE.0 .OR. ITHRM(K)) GO TO 10
     ITHRM(K) = .TRUE.
     LINE(1) = '; ';
     LINE(1) = ISTR
     L = 2
111 CONTINUE
     READ (LUNIT,';(A)';,END=40) LINE(L)
     IF (IPPLEN(LINE(L)) .GE. 80) THEN
        IF (LINE(L)(80:80) .EQ. ';4';) THEN
           GO TO 25
        ELSEIF (LINE(L)(80:80).EQ.';2'; .OR.
    1           LINE(L)(80:80).EQ.';3';) THEN
           L = L + 1
        ENDIF
     ENDIF
     GO TO 111
C
  25 CONTINUE
C
     ICOL = 20
     DO 60 I = 1, 5
        ICOL = ICOL + 5
        IF (I .EQ. 5) ICOL = 74
        ELEM  = LINE(1)(ICOL:ICOL+1)
        IELEM = 0
C
        IF (LINE(1)(ICOL+2:ICOL+4) .NE. '; ';) THEN
           CALL IPPARR
    1      (LINE(1)(ICOL+2:ICOL+4), 0, 1, value, NVAL, IER, LOUT)
           IELEM = value(1)
        ENDIF
C
        IF (ELEM.NE.'; '; .AND. IELEM.NE.0) THEN
           IF (UPCASE(ELEM, 1) .EQ. ';E';)
    1             KCHRG(K)=KCHRG(K)+IELEM*(-1)
           CALL CKCOMP (ELEM, ENAME, MM, M)
           IF (M .GT. 0) THEN
              KNCF(M,K) = IELEM
              WTM(K) = WTM(K) + AWT(M)*FLOAT(IELEM)
           ELSE
              WRITE (LOUT, 100) ELEM,KNAME(K)(:10)
              KERR = .TRUE.
           ENDIF
        ENDIF
  60 CONTINUE
C
     IF (UPCASE(LINE(1)(45:),1) .EQ. ';L';) KPHSE(K)=1
     IF (UPCASE(LINE(1)(45:),1) .EQ. ';S';) KPHSE(K)=-1
     T(1,K) = TLO
     IF (LINE(1)(46:55) .NE. '; ';) CALL IPPARR
    1   (LINE(1)(46:55), 0, 1, T(1,K), NVAL, IER, LOUT)
C
     T(2,K) = TMID
     IF (LINE(1)(66:73) .NE. '; ';) CALL IPPARR
    1   (LINE(1)(66:73), 0, 1, T(2,K), NVAL, IER, LOUT)
C
     T(NT(K),K) = THI
     IF (LINE(1)(56:65) .NE. '; ';) CALL IPPARR
    1   (LINE(1)(56:65), 0, 1, T(NT(K),K), NVAL, IER, LOUT)
C
     READ (LINE(2)(:75),';(5E15.8)';) (A(I,NTR,K),I=1,5)
     READ (LINE(3)(:75),';(5E15.8)';)
    1            (A(I,NTR,K),I=6,7),(A(I,1,K),I=1,3)
     READ (LINE(4)(:60),';(4E15.8)';) (A(I,1,K),I=4,7)
     GO TO 10
C
  40 RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKREAC (LINE, II, KK, KNAME, LOUT, MAXSP, NSPEC, NREAC,
    1                   NUNK, NU, NPAR, PAR, NTHB, ITHB,
    2                   NFAL, IFAL, KFAL, NWL, IWL, WL,
    3                   NRNU, IRNU, RNU, KERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION NSPEC(*), NREAC(*), NUNK(MAXSP,*), NU(MAXSP,*),
    1          PAR(NPAR,*), IFAL(*), KFAL(*), ITHB(*), IWL(*), WL(*),
    2          IRNU(*), RNU(MAXSP,*), IPLUS(20)
     CHARACTER*(*) KNAME(*), LINE
     CHARACTER CNUM(11)*1, UPCASE*4
     CHARACTER*80 ISTR, IREAC, IPROD, ISPEC, INAME, ITEMP
     LOGICAL KERR, LTHB, LWL, LRSTO
     DATA CNUM/';.';,';0';,';1';,';2';,';3';,';4';,';5';,';6';,';7';,';8';,';9';/
C
     LTHB = .FALSE.
     LWL = .FALSE.
     NSPEC(II) = 0
     NREAC(II) = 0
     CALL IPNPAR (LINE, NPAR, ISTR, ISTART)
     CALL IPPARR (ISTR, 1, NPAR, PAR(1,II), NVAL, IER, LOUT)
     KERR = KERR .OR. (IER.NE.0)
     INAME = '; ';
     ILEN = 0
     DO 10 I = 1, ISTART-1
        IF (LINE(I:I) .NE. '; ';) THEN
           ILEN = ILEN+1
           INAME(ILEN:ILEN) = LINE(I:I)
        ENDIF
  10 CONTINUE
     I1 = 0
     I2 = 0
     DO 25 I = 1, ILEN
        IF (I1 .LE. 0) THEN
           IF (INAME(I:I+2) .EQ. ';<=>';) THEN
              I1 = I
              I2 = I+2
              IR = 1
           ELSEIF (INAME(I:I+1) .EQ. ';=>';) THEN
              I1 = I
              I2 = I+1
              IR = -1
           ELSEIF (I.GT.1 .AND. INAME(I:I).EQ.';=';
    1                  .AND. INAME(I-1:I-1).NE.';=';) THEN
              I1 = I
              I2 = I
              IR = 1
           ENDIF
        ENDIF
  25 CONTINUE
C
     IF (ILASCH(INAME).GE.45 .AND. I1.GT.0) THEN
        WRITE (LOUT, 1900) II,INAME(:I1-1),(PAR(N,II),N=1,NPAR)
        WRITE (LOUT, 1920) INAME(I1:)
     ELSE
         WRITE (LOUT, 1900) II,INAME(:45),(PAR(N,II),N=1,NPAR)
     ENDIF
C
     IREAC = '; ';
     IPROD = '; ';
     IF (I1 .GT. 0) THEN
        IREAC = INAME(:I1-1)
        IPROD = INAME(I2+1:)
     ELSE
        WRITE (LOUT, 660)
        KERR = .TRUE.
        RETURN
     ENDIF
C
     LRSTO = ((INDEX(IREAC,';.';).GT.0) .OR. (INDEX(IPROD,';.';).GT.0))
     IF (LRSTO) THEN
        NRNU = NRNU + 1
        IRNU(NRNU) = II
     ENDIF
C
     IF (INDEX(IREAC,';=>';).GT.0 .OR. INDEX(IPROD,';=>';).GT.0) THEN
        WRITE (LOUT, 800)
        KERR = .TRUE.
        RETURN
     ENDIF
     IF (INDEX(IREAC,';(+';).GT.0 .OR. INDEX(IPROD,';(+';).GT.0) THEN
        KRTB = 0
        KPTB = 0
        DO 300 J = 1, 2
           ISTR = '; ';
           KTB  = 0
           IF (J .EQ. 1) THEN
              ISTR = IREAC
           ELSE
              ISTR = IPROD
           ENDIF
C
           DO 35 N = 1, ILASCH(ISTR)-1
              IF (ISTR(N:N+1) .EQ. ';(+';) THEN
                 I1 = N+2
                 I2 = I1 + INDEX(ISTR(I1:),';)';)-1
                 IF (I2 .GT. I1) THEN
                    IF (ISTR(I1:I2-1).EQ.';M'; .OR.
    1                   ISTR(I1:I2-1).EQ.';m';) THEN
                        IF (KTB .NE. 0) THEN
                           WRITE (LOUT, 630)
                           KERR = .TRUE.
                           RETURN
                        ELSE
                           KTB = -1
                        ENDIF
                    ELSE
                       CALL CKCOMP (ISTR(I1:I2-1), KNAME, KK, KNUM)
                       IF (KNUM .GT. 0) THEN
                          IF (KTB .NE. 0) THEN
                             WRITE (LOUT, 630)
                             KERR = .TRUE.
                             RETURN
                          ELSE
                             KTB = KNUM
                          ENDIF
                       ENDIF
                    ENDIF
                    IF (KTB .NE. 0) THEN
                       ITEMP = '; ';
                       IF (I1 .EQ. 1) THEN
                          ITEMP = ISTR(I2+1:)
                       ELSE
                          ITEMP = ISTR(:I1-3)//ISTR(I2+1:)
                       ENDIF
                       IF (J .EQ. 1) THEN
                          IREAC = '; ';
                          IREAC = ITEMP
                          KRTB = KTB
                       ELSE
                          IPROD = '; ';
                          IPROD = ITEMP
                          KPTB = KTB
                       ENDIF
                    ENDIF
                 ENDIF
              ENDIF
  35       CONTINUE
300    CONTINUE
C
        IF (KRTB.NE.0 .OR. KPTB.NE.0) THEN
           IF (KRTB.LE.0 .AND. KPTB.LE.0) THEN
C
              NFAL = NFAL + 1
              IFAL(NFAL) = II
              KFAL(NFAL) = 0
C
              LTHB = .TRUE.
              NTHB = NTHB + 1
              ITHB(NTHB) = II
C
           ELSEIF (KRTB .EQ. KPTB) THEN
              NFAL = NFAL + 1
              IFAL(NFAL) = II
              KFAL(NFAL) = KRTB
C
           ELSE
C
              WRITE (LOUT, 640)
              KERR = .TRUE.
              RETURN
           ENDIF
        ENDIF
     ENDIF
     DO 600 J = 1, 2
        ISTR = '; ';
        LTHB = .FALSE.
        IF (J .EQ. 1) THEN
           ISTR = IREAC
           NS = 0
        ELSE
           ISTR = IPROD
           NS = 3
        ENDIF
        NPLUS = 1
        IPLUS(NPLUS) = 0
        DO 500 L = 2, ILASCH(ISTR)-1
           IF (ISTR(L).EQ.';+';) THEN
              NPLUS = NPLUS + 1
              IPLUS(NPLUS) = L
           ENDIF
500    CONTINUE
        NPLUS = NPLUS + 1
        IPLUS(NPLUS) = ILASCH(ISTR)+1
C
        NSTART = 1
505    CONTINUE
        N1 = NSTART
        DO 510 N = NPLUS, N1, -1
           ISPEC = '; ';
           ISPEC = ISTR(IPLUS(N1)+1 : IPLUS(N)-1)
C
           IF (UPCASE(ISPEC, 1).EQ.';M'; .AND.
    1               (ISPEC(2:2).EQ.'; '; .OR. ISPEC(2:2).EQ.';+';)) THEN
              IF (LTHB) THEN
                 WRITE (LOUT, 900)
                 KERR = .TRUE.
                 RETURN
              ELSEIF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II) THEN
                 WRITE (LOUT, 640)
                 KERR = .TRUE.
                 RETURN
              ELSE
                 LTHB = .TRUE.
                 IF (NTHB.EQ.0 .OR.
    1               (NTHB.GT.0.AND.ITHB(NTHB).NE.II)) THEN
                     NTHB = NTHB + 1
                     ITHB(NTHB) = II
                 ENDIF
                 IF (N .EQ. NPLUS) GO TO 600
                 NSTART = N
                 GO TO 505
              ENDIF
C
           ELSEIF (UPCASE(ISPEC, 2) .EQ. ';HV';) THEN
              IF (LWL) THEN
                 WRITE (LOUT, 670)
                 KERR = .TRUE.
                 RETURN
              ELSE
                 LWL = .TRUE.
                 NWL = NWL + 1
                 IWL(NWL) = II
                 WL(NWL) = 1.0
                 IF (J .EQ. 1) WL(NWL) = -1.0
                 IF (N .EQ. NPLUS) GO TO 600
                 NSTART = N
                 GO TO 505
              ENDIF
           ENDIF
           IND = 0
           DO 334 L = 1, LEN(ISPEC)
              NTEST = 0
              DO 333 M = 1, 11
                 IF (ISPEC(L) .EQ. CNUM(M)) THEN
                    NTEST=M
                    IND = L
                 ENDIF
333          CONTINUE
              IF (NTEST .EQ. 0) GO TO 335
334       CONTINUE
335       CONTINUE
C
           RVAL = 1.0
           IVAL = 1
           IF (IND .GT. 0) THEN
              IF (LRSTO) THEN
                 CALL IPPARR (ISPEC(:IND), 1, 1, RVAL, NVAL,
    1                         IER, LOUT)
              ELSE
                 CALL IPPARI (ISPEC(:IND), 1, 1, IVAL, NVAL,
    1                        IER, LOUT)
              ENDIF
              IF (IER .EQ. 0) THEN
                 ITEMP = '; ';
                 ITEMP = ISPEC(IND+1:)
                 ISPEC = '; ';
                 ISPEC = ITEMP
              ELSE
                 KERR = .TRUE.
                 RETURN
              ENDIF
           ENDIF
C
           CALL CKCOMP (ISPEC, KNAME, KK, KNUM)
           IF (KNUM .EQ. 0) THEN
              IF ((N-N1) .GT. 1) GO TO 510
              WRITE (LOUT, 680) ISPEC(:ILASCH(ISPEC))
              KERR = .TRUE.
           ELSE
              IF (J .EQ. 1) THEN
                 IVAL = -IVAL
                 RVAL = -RVAL
              ENDIF
              NNUM = 0
              IF (LRSTO) THEN
                 DO 110 K = 1, NS
                    IF (KNUM.EQ.NUNK(K,II) .AND.
    1                   RNU(K,NRNU)/RVAL.GT.0) THEN
                        NNUM = K
                        RNU(NNUM,NRNU) = RNU(NNUM,NRNU) + RVAL
                    ENDIF
110             CONTINUE
              ELSE
                 DO 111 K = 1, NS
                    IF (KNUM.EQ.NUNK(K,II) .AND.
    1                   NU(K,II)/IVAL.GT.0) THEN
                       NNUM=K
                       NU(NNUM,II) = NU(NNUM,II) + IVAL
                    ENDIF
111             CONTINUE
              ENDIF
C
              IF (NNUM .LE. 0) THEN
                 IF (J.EQ.1 .AND. NS.EQ.3) THEN
                    WRITE (LOUT, 690)
                    KERR = .TRUE.
                    RETURN
                 ELSEIF (J.EQ.2 .AND. NS.EQ.MAXSP) THEN
                    WRITE (LOUT, 700)
                    KERR = .TRUE.
                    RETURN
                 ELSE
                    NS = NS + 1
                    NSPEC(II) = NSPEC(II)+1
                    IF (J .EQ. 1) NREAC(II) = NS
                    NUNK(NS,II) = KNUM
                    IF (LRSTO) THEN
                       RNU(NS,NRNU) = RVAL
                    ELSE
                       NU(NS,II)   = IVAL
                    ENDIF
                 ENDIF
              ENDIF
           ENDIF
           IF (N .EQ. NPLUS) GO TO 600
           NSTART = N
           GO TO 505
C
510    CONTINUE
600 CONTINUE
C
     NSPEC(II) = IR*NSPEC(II)
     RETURN
     END
C----------------------------------------------------------------------

rhong

SUBROUTINE CKAUXL (SUB, NSUB, II, KK, KNAME, LOUT, MAXSP, NPAR,
    1                   NSPEC, NTHB, ITHB, NTBS, MAXTB, NKTB, AIK,
    2                   NFAL, IFAL, IDUP, NFAR, PFAL, IFOP, NLAN,
    3                   ILAN, NLAR, PLAN, NREV, IREV, RPAR, NRLT, IRLT,
    4                   RLAN, NWL, IWL, WL, KERR, NORD, IORD, MAXORD,
    5                   KORD, RORD, NUNK, NU, NRNU, IRNU, RNU,
    6                   NEIM, IEIM, ITDEP, NJAN, IJAN, NJAR, PJAN,
    7                   NFT1, IFT1, NF1R, PFT1, NEXC, IEXC, PEXC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION NSPEC(*), ITHB(*), NTBS(*), NKTB(MAXTB,*), IDUP(*),
    1          AIK(MAXTB,*), IFAL(*), IFOP(*), PFAL(NFAR,*),
    2          ILAN(*), PLAN(NLAR,*), IREV(*), RPAR(NPAR,*), IRLT(*),
    3          RLAN(NLAR,*), IWL(*), WL(*), VAL(1), IORD(*),
    4          KORD(MAXORD,*), RORD(MAXORD,*), NUNK(MAXSP,*),
    5          NU(MAXSP,*), IRNU(*), RNU(MAXSP,*)
C
     DIMENSION IEIM(*), ITDEP(*), IJAN(*), PJAN(NJAR,*), IFT1(*),
    1          PFT1(NF1R,*), IEXC(*), PEXC(*)
C
     CHARACTER*(*) SUB(*), KNAME(*)
     CHARACTER*80 KEY, RSTR, ISTR
     CHARACTER UPCASE*4
     LOGICAL KERR, LLAN, LRLT, LTHB, LFAL, LTRO, LSRI, LWL, LREV,
    1        LFORD, LRORD, LEIM, LJAN, LFT1, LEXC
C
     LTHB = (NTHB.GT.0 .AND. ITHB(NTHB).EQ.II)
     LFAL = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II)
     LWL  = (NWL .GT.0 .AND. IWL(NWL)  .EQ.II)
     LREV = (NREV.GT.0 .AND. IREV(NREV).EQ.II)
     LLAN = (NLAN.GT.0 .AND. ILAN(NLAN).EQ.II)
     LRLT = (NRLT.GT.0 .AND. IRLT(NRLT).EQ.II)
     LTRO = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).GT.2)
     LSRI = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).EQ.2)
     LEIM = (NEIM.GT.0 .AND. IEIM(NEIM).EQ.II)
     LJAN = (NJAN.GT.0 .AND. IJAN(NJAN).EQ.II)
     LFT1 = (NFT1.GT.0 .AND. IFT1(NFT1).EQ.II)
     LEXC = (NEXC.GT.0 .AND. IEXC(NEXC).EQ.II)
C
     DO 500 N = 1, NSUB
        ILEN = ILASCH(SUB(N))
        KEY = '; ';
C
        IF ( UPCASE(SUB(N), 3) .EQ. ';DUP';) THEN
           IDUP(II) = -1
           WRITE (LOUT, 4000)
           GO TO 500
        ELSE
           I1 = INDEX(SUB(N),';/';)
           I2 = INDEX(SUB(N)(I1+1,';/';)
           IF (I1.LE.0 .OR. I2.LE.0) THEN
              KERR = .TRUE.
              WRITE (LOUT, 2090) SUB(N)(:ILEN)
              GO TO 500
           ENDIF
           KEY = SUB(N)(:I1-1)
           RSTR = '; ';
           RSTR = SUB(N)(I1+1:I1+I2-1)
        ENDIF
C
        IF (UPCASE(KEY, 3).EQ.';LOW'; .OR.
    1       UPCASE(KEY, 4).EQ.';TROE';.OR.
    2       UPCASE(KEY, 3).EQ.';SRI';) THEN
           IF ((.NOT.LFAL) .OR. LLAN .OR. LRLT .OR. LREV) THEN
              KERR = .TRUE.
              IF (.NOT. LFAL) WRITE (LOUT, 1050) SUB(N)(:ILEN)
              IF (LLAN)       WRITE (LOUT, 1060) SUB(N)(:ILEN)
              IF (LRLT)       WRITE (LOUT, 1070) SUB(N)(:ILEN)
              IF (LREV)       WRITE (LOUT, 1090) SUB(N)(:ILEN)
           ELSE
C
              IF (UPCASE(KEY, 3) .EQ. ';LOW';) THEN
                 IF (IFOP(NFAL) .GT. 0) THEN
                    WRITE (LOUT, 2000) SUB(N)(:ILEN)
                    KERR = .TRUE.
                 ELSE
                    IFOP(NFAL) = ABS(IFOP(NFAL))
                    CALL IPPARR (RSTR,1,3,PFAL(1,NFAL),NVAL,IER,LOUT)
                    KERR = KERR .OR. (IER.NE.0)
                    WRITE (LOUT, 3050) (PFAL(L,NFAL),L=1,3)
                 ENDIF
C
              ELSEIF (UPCASE(KEY, 4) .EQ. ';TROE';) THEN
                 IF (LTRO .OR. LSRI) THEN
                    KERR = .TRUE.
                    IF (LTRO) WRITE (LOUT, 2010) SUB(N)(:ILEN)
                    IF (LSRI) WRITE (LOUT, 2030) SUB(N)(:ILEN)
                 ELSE
                    LTRO = .TRUE.
                    CALL IPPARR (RSTR,1,-4,PFAL(4,NFAL),NVAL,IER,LOUT)
                    IF (NVAL .EQ. 3) THEN
                       IFOP(NFAL) = 3*IFOP(NFAL)
                       WRITE (LOUT, 3080) (PFAL(L,NFAL),L=4,6)
                    ELSEIF (NVAL .EQ. 4) THEN
                       IFOP(NFAL) = 4*IFOP(NFAL)
                       WRITE (LOUT, 3090) (PFAL(L,NFAL),L=4,7)
                    ELSE
                       WRITE (LOUT, 2020) SUB(N)(:ILEN)
                       KERR = .TRUE.
                    ENDIF
                 ENDIF
C
              ELSEIF (UPCASE(KEY, 3) .EQ. ';SRI';) THEN
                 IF (LTRO .OR. LSRI) THEN
                    KERR = .TRUE.
                    IF (LTRO) WRITE (LOUT, 2030) SUB(N)(:ILEN)
                    IF (LSRI) WRITE (LOUT, 2040) SUB(N)(:ILEN)
                 ELSE
                    LSRI = .TRUE.
                    IFOP(NFAL) = 2*IFOP(NFAL)
                    CALL IPPARR (RSTR,1,-5,PFAL(4,NFAL),NVAL,IER,LOUT)
                    IF (NVAL .EQ. 3) THEN
                       PFAL(7,NFAL) = 1.0
                       PFAL(8,NFAL) = 0.0
                       WRITE (LOUT, 3060) (PFAL(L,NFAL),L=4,6)
                    ELSEIF (NVAL .EQ. 5) THEN
                       WRITE (LOUT, 3070) (PFAL(L,NFAL),L=4,8)
                    ELSE
                       WRITE (LOUT, 2020) SUB(N)(:ILEN)
                       KERR = .TRUE.
                    ENDIF
                 ENDIF
              ENDIF
           ENDIF
C
        ELSEIF (UPCASE(KEY, 3) .EQ. ';REV';) THEN
           IF (LFAL .OR. LREV .OR. NSPEC(II).LT.0) THEN
              KERR = .TRUE.
              IF (LFAL) WRITE (LOUT, 1090) SUB(N)(:ILEN)
              IF (LREV) WRITE (LOUT, 2050) SUB(N)(:ILEN)
              IF (NSPEC(II) .LT. 0) WRITE (LOUT, 2060) SUB(N)(:ILEN)
           ELSE
              LREV = .TRUE.
              NREV = NREV+1
              IREV(NREV) = II
              CALL IPPARR (RSTR,1,NPAR,RPAR(1,NREV),NVAL,IER,LOUT)
              KERR = KERR .OR. (IER.NE.0)
              WRITE (LOUT, 1900) ';   Reverse Arrhenius coefficients:';,
    1                           (RPAR(L,NREV),L=1,3)
           ENDIF
C
        ELSEIF (UPCASE(KEY, 3) .EQ. ';RLT';) THEN
           IF (LFAL .OR. LRLT .OR. NSPEC(II).LT.0) THEN
              KERR = .TRUE.
              IF (LFAL) WRITE (LOUT, 1070) SUB(N)(:ILEN)
              IF (LRLT) WRITE (LOUT, 2080) SUB(N)(:ILEN)
              IF (NSPEC(II) .LT. 0) WRITE (LOUT, 1080) SUB(N)(:ILEN)
           ELSE
              LRLT = .TRUE.
              NRLT = NRLT + 1
              IRLT(NRLT) = II
              CALL IPPARR (RSTR,1,NLAR,RLAN(1,NRLT),NVAL,IER,LOUT)
              KERR = KERR .OR. (IER.NE.0)
              WRITE (LOUT, 3040) (RLAN(L,NRLT),L=1,2)
           ENDIF
C
        ELSEIF (UPCASE(KEY, 2) .EQ. ';HV';) THEN
           IF (.NOT.LWL) THEN
              WRITE (LOUT, 1000) SUB(N)(:ILEN)
              KERR = .TRUE.
           ELSE
              CALL IPPARR (RSTR,1,1,VAL,NVAL,IER,LOUT)
              IF (IER .EQ. 0) THEN
                 WL(NWL) = WL(NWL)*VAL(1)
                 WRITE (LOUT, 3020) ABS(WL(NWL))
              ELSE
                 WRITE (LOUT, 1000) SUB(N)(:ILEN)
                 KERR = .TRUE.
              ENDIF
           ENDIF
C
        ELSEIF (UPCASE(KEY, 2) .EQ. ';LT';) THEN
           IF (LFAL .OR. LLAN) THEN
              KERR = .TRUE.
              IF (LFAL) WRITE (LOUT, 1060) SUB(N)(:ILEN)
              IF (LLAN) WRITE (LOUT, 2070) SUB(N)(:ILEN)
           ELSE
              LLAN = .TRUE.
              NLAN = NLAN + 1
              ILAN(NLAN) = II
              CALL IPPARR (RSTR,1,NLAR,PLAN(1,NLAN),NVAL,IER,LOUT)
              IF (IER .NE. 0) THEN
                 WRITE (LOUT, 1010) SUB(N)(:ILEN)
                 KERR = .TRUE.
              ENDIF
              WRITE (LOUT, 3000) (PLAN(L,NLAN),L=1,2)
           ENDIF
C
        ELSEIF (UPCASE(KEY,4).EQ.';FORD'; .OR.
    1           UPCASE(KEY,4).EQ.';RORD';) THEN
            LFORD = (UPCASE(KEY,4) .EQ. ';FORD';)
            LRORD = (UPCASE(KEY,4) .EQ. ';RORD';)
            IF (LRORD .AND. NSPEC(II).LT.0) THEN
               KERR = .TRUE.
               WRITE (LOUT, 2065)
            ELSE
            IF (NORD.EQ.0 .OR.(NORD.GT.0 .AND. IORD(NORD).NE.II)) THEN
               NORD = NORD + 1
               IORD(NORD) = II
               NKORD = 0
C
               IF (NRNU.GT.0 .AND. IRNU(NRNU).EQ.II) THEN
                  DO 111 L = 1, 6
                     IF (NUNK(L,II) .NE. 0) THEN
                        NKORD = NKORD + 1
                        IF (RNU(L,NRNU) .LT. 0.0) THEN
                           KORD(NKORD,NORD) = -NUNK(L,II)
                           RORD(NKORD,NORD) = ABS(RNU(L,NRNU))
                        ELSE
                           KORD(NKORD,NORD) = NUNK(L,II)
                           RORD(NKORD,NORD) = RNU(L,NRNU)
                        ENDIF
                     ENDIF
111              CONTINUE
              ELSE
                  DO 113 L = 1, 6
                     IF (NUNK(L,II) .NE. 0) THEN
                        NKORD = NKORD + 1
                        IF (NU(L,II) .LT. 0) THEN
                           KORD(NKORD,NORD) = -NUNK(L,II)
                           RORD(NKORD,NORD) =  IABS(NU(L,II))
                        ELSE
                           KORD(NKORD,NORD) = NUNK(L,II)
                           RORD(NKORD,NORD) = NU(L,II)
                        ENDIF
                     ENDIF
113              CONTINUE
               ENDIF
            ENDIF
            ENDIF
C
            CALL IPNPAR (RSTR, 1, ISTR, ISTART)
            IF (ISTART .GE. 1) THEN
               CALL IPPARR (ISTR, 1, 1, VAL, NVAL, IER, LOUT)
               CALL CKCOMP (RSTR(:ISTART-1), KNAME, KK, K)
               IF (LFORD) K = -K
               NK = 0
               DO 121 L = 1, MAXORD
C
                  IF (KORD(L,NORD).EQ.0) THEN
                     NK = L
                     GO TO 122
                  ELSEIF (KORD(L,NORD).EQ.K) THEN
                     IF (LFORD) THEN
                        WRITE (LOUT,*)
    1';       Warning...changing order for reactant...';,
    2                   KNAME(IABS(K))
                     ELSE
                        WRITE (LOUT,*)
    1';       Warning...changing order for product...';,
    2                   KNAME(K)
                     ENDIF
                     NK = L
                     GO TO 122
                  ENDIF
121           CONTINUE
122           CONTINUE
               KORD(NK,NORD) = K
               RORD(NK,NORD) = VAL(1)
               IF (LFORD) THEN
                  WRITE (LOUT, 3015) KNAME(IABS(K)),VAL(1)
               ELSE
                  WRITE (LOUT, 3016) KNAME(K),VAL(1)
               ENDIF
           ENDIF
C
        ELSEIF (UPCASE(KEY, 3) .EQ. ';EIM';) THEN
           NEIM = NEIM + 1
           IEIM(NEIM) = II
           IF (LTHB) THEN
              WRITE (LOUT, 1100) SUB(N)(:ILEN)
              KERR = .TRUE.
           ENDIF
           CALL IPPARI (RSTR, 1, 1, ITDEP(NEIM), NVAL, IER, LOUT)
           KERR = KERR .OR. (IER.NE.0) .OR. (NVAL.NE.1)
           WRITE (LOUT, 3100) ITDEP(NEIM)
C
        ELSEIF (UPCASE(KEY, 3) .EQ. ';JAN';) THEN
           NJAN = NJAN + 1
           IJAN(NJAN) = II
           CALL IPPARR (RSTR,1,NJAR,PJAN(1,NJAN),NVAL,IER,LOUT)
           IF (IER .NE. 0) THEN
              WRITE (LOUT, 1110) SUB(N)(:ILEN)
              KERR = .TRUE.
           ENDIF
           WRITE (LOUT, 3110) (PJAN(L,NJAN), L = 1, NJAR)
C
        ELSEIF (UPCASE(KEY, 4) .EQ. ';FIT1';) THEN
           NFT1 = NFT1 + 1
           IFT1(NFT1) = II
           CALL IPPARR (RSTR,1,NF1R,PFT1(1,NFT1),NVAL,IER,LOUT)
           IF (IER .NE. 0) THEN
              WRITE (LOUT, 1112) SUB(N)(:ILEN)
              KERR = .TRUE.
           ENDIF
           WRITE (LOUT, 3112) (PFT1(L,NFT1), L = 1, NF1R)
C
        ELSEIF (UPCASE(KEY, 4) .EQ. ';EXCI';) THEN
           NEXC = NEXC + 1
           IEXC(NEXC) = II
           CALL IPPARR (RSTR,1,1,PEXC(NEXC),NVAL,IER,LOUT)
           KERR = KERR .OR. (IER.NE.0) .OR. (NVAL.NE.1)
           WRITE (LOUT, 3114) PEXC(NEXC)
C
        ELSE
           CALL CKCOMP (KEY, KNAME, KK, K)
           IF (K .EQ. 0) THEN
              WRITE (LOUT, 1040) KEY(:ILASCH(KEY))
              KERR = .TRUE.
           ELSE
              IF (.NOT.LTHB) THEN
                 KERR = .TRUE.
                 WRITE (LOUT, 1020) SUB(N)(:ILEN)
              ELSE
                 IF (NTBS(NTHB) .EQ. MAXTB) THEN
                    KERR = .TRUE.
                    WRITE (LOUT, 1030) SUB(N)(:ILEN)
                 ELSE
                    CALL IPPARR (RSTR, 1, 1, VAL, NVAL, IER, LOUT)
                    IF (IER .EQ. 0) THEN
                       WRITE (LOUT, 3010) KNAME(K),VAL(1)
                       NTBS(NTHB) = NTBS(NTHB) + 1
                       NKTB(NTBS(NTHB),NTHB) = K
                       AIK(NTBS(NTHB),NTHB) = VAL(1)
                    ELSE
                       WRITE (LOUT, 1020) SUB(N)(:ILEN)
                       KERR = .TRUE.
                    ENDIF
                 ENDIF
              ENDIF
           ENDIF
        ENDIF
500 CONTINUE
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM,
    1                   KPHSE, KCHRG, NT, T, TLO, TMID, THI, KNCF,
    2                   ITHRM, LOUT, KERR)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION WTM(*), KPHSE(*), KCHRG(*), T(MAXTP,*),
    1          NT(*), KNCF(MDIM,*), IPLUS(10)
     LOGICAL KERR, ITHRM(*)
     CHARACTER*(*) ENAME(*), KNAME(*)
     CHARACTER*1 IPHSE(3), INUM(10)
     DATA IPHSE/';S';,';G';,';L';/
     DATA INUM/';0';,';1';,';2';,';3';,';4';,';5';,';6';,';7';,';8';,';9';/
C
     WRITE (LOUT, 400) (ENAME(M), M = 1, MM)
     WRITE (LOUT, 300)
C
     DO 100 K = 1, KK
C
        IF (T(1,K) .LT. 0.0) T(1,K) = TLO
        IF (T(2,K) .LT. 0.0) T(2,K) = TMID
        IF (T(3,K) .LT. 0.0) T(NT(K),K) = THI
        WRITE (LOUT, 500) K, KNAME(K), IPHSE(KPHSE(K)+2), KCHRG(K),
    1                    WTM(K), INT(T(1,K)), INT(T(NT(K),K)),
    2                   (KNCF(M,K),M=1,MM)
        IF (T(1,K) .GE. T(NT(K),K)) THEN
           KERR = .TRUE.
           WRITE (LOUT, 240)
        ENDIF
        IF (T(1,K) .GT. T(2,K)) THEN
           WRITE (LOUT, 250)
           KERR = .TRUE.
        ENDIF
        IF (T(NT(K),K) .LT. T(2,K)) THEN
           WRITE (LOUT, 260)
           KERR = .TRUE.
        ENDIF
        IF (.NOT. ITHRM(K)) THEN
           KERR = .TRUE.
           WRITE (LOUT, 200)
        ENDIF
        CALL CKCOMP (KNAME(K)(:1), INUM, 10, I)
        IF (I .GT. 0) THEN
           KERR = .TRUE.
           WRITE (LOUT, 210)
        ENDIF
        NPLUS = 0
        DO 50 N = 1, ILASCH(KNAME(K))
           IF (KNAME(K)(N:N) .EQ. ';+';) THEN
              NPLUS = NPLUS + 1
              IPLUS(NPLUS) = N
           ENDIF
  50    CONTINUE
        DO 60 N = 1, NPLUS
           I1 = IPLUS(N)
           IF (I1 .EQ. 1) THEN
              WRITE (LOUT, 220)
              KERR = .TRUE.
           ELSE
              IF (KNAME(K)(I1-1:I1-1) .EQ. ';(';) THEN
                 I1 = I1 + 1
                 I2 = I1 + INDEX(KNAME(K)(I1,';)';)-1
                 IF (I2 .GT. I1) THEN
                    CALL CKCOMP (KNAME(K)(I1:I2-1), KNAME, KK, KNUM)
                    IF (KNUM .GT. 0) THEN
                       WRITE (LOUT, 230)
                       KERR = .TRUE.
                    ENDIF
                 ENDIF
              ENDIF
              I1 = I1 + 1
              IF (N .LT. NPLUS) THEN
                 DO 55 L = N+1, NPLUS
                    I2 = IPLUS(L)
                    IF (I2 .GT. I1) THEN
                       CALL CKCOMP (KNAME(K)(I1:I2-1),KNAME,KK,KNUM)
                       IF (KNUM .GT. 0) THEN
                          WRITE (LOUT, 230)
                          KERR = .TRUE.
                       ENDIF
                    ENDIF
  55             CONTINUE
              ENDIF
C
              I2 = ILASCH(KNAME(K))
              IF (I2 .GE. I1) THEN
                 CALL CKCOMP (KNAME(K)(I1:I2), KNAME, KK, KNUM)
                 IF (KNUM .GT. 0) THEN
                    WRITE (LOUT, 230)
                    KERR = .TRUE.
                 ENDIF
              ENDIF
           ENDIF
  60    CONTINUE
C
100 CONTINUE
     WRITE (LOUT, 300)
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR, AUNITS,
    1                   EUNITS, NREAC, NUNK, NU, KCHRG, MDIM, MM, KNCF,
    2                   IDUP, NFAL, IFAL, KFAL, NFAR, PFAL, IFOP, NREV,
    3                   IREV, NTHB, ITHB, NLAN, ILAN, NRLT, IRLT, KERR,
    4                   LOUT, NRNU, IRNU, RNU, CKMIN)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DOUBLE PRECISION RU_JOUL,        AVAG,                ONE
     PARAMETER (RU_JOUL = 8.314510D0, AVAG = 6.0221367D23, ONE=1.0D0)
     DIMENSION NSPEC(*), PAR(NPAR,*), RPAR(NPAR,*), NREAC(*),
    1          NUNK(MAXSP,*), NU(MAXSP,*), KCHRG(*), KNCF(MDIM,*),
    2          IDUP(*), IFAL(*), KFAL(*), PFAL(NFAR,*), IFOP(*),
    3          IREV(*), ITHB(*), ILAN(*), IRLT(*), IRNU(*),
    4          RNU(MAXSP,*)
     CHARACTER*(*) AUNITS, EUNITS
     LOGICAL IERR,KERR,LREV,LLAN,LRLT
C
     IF (NRNU.GT.0 .AND. (II.EQ.IRNU(NRNU))) THEN
        CALL CKRBAL (MAXSP, NUNK(1,II), RNU(1,NRNU), MDIM, MM, KCHRG,
    1                KNCF, CKMIN, IERR)
     ELSE
        CALL CKBAL (MAXSP, NUNK(1,II), NU(1,II), MDIM, MM, KCHRG, KNCF,
    1               IERR)
     ENDIF
C
     IF (IERR) THEN
        KERR = .TRUE.
        WRITE (LOUT, 1060)
     ENDIF
C
     CALL CKDUP (II, MAXSP, NSPEC, NREAC, NU, NUNK, NFAL, IFAL, KFAL,
    1            ISAME)
C
     IF (ISAME .GT. 0) THEN
        IF (IDUP(ISAME).NE.0 .AND. IDUP(II).NE.0) THEN
           IDUP(ISAME) = ABS(IDUP(ISAME))
           IDUP(II)    = ABS(IDUP(II))
        ELSE
           N1 = 0
           N2 = 0
           IF (NTHB .GT. 1) THEN
              DO 150 N = 1, NTHB
                 IF (ITHB(N) .EQ. ISAME) N1 = 1
                 IF (ITHB(N) .EQ. II)    N2 = 1
150          CONTINUE
           ENDIF
           IF (N1 .EQ. N2) THEN
              KERR = .TRUE.
              WRITE (LOUT, 1050) ISAME
           ENDIF
        ENDIF
     ENDIF
C
     IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).LT.0) THEN
        KERR = .TRUE.
        WRITE (LOUT, 1020)
     ENDIF
C
     LREV = (NREV.GT.0 .AND. IREV(NREV).EQ.II)
     LLAN = (NLAN.GT.0 .AND. ILAN(NLAN).EQ.II)
     LRLT = (NRLT.GT.0 .AND. IRLT(NRLT).EQ.II)
     IF (LREV .AND. LLAN .AND. (.NOT.LRLT)) THEN
        KERR = .TRUE.
        WRITE (LOUT, 1030)
     ENDIF
     IF (LRLT .AND. (.NOT.LLAN)) THEN
        KERR = .TRUE.
        WRITE (LOUT, 1040)
     ENDIF
     IF (LRLT .AND. (.NOT.LREV)) THEN
        KERR = .TRUE.
        WRITE (LOUT, 1045)
     ENDIF
C
     IF (EUNITS .EQ. ';KELV';) THEN
        EFAC = 1.0
     ELSEIF (EUNITS .EQ. ';CAL/';) THEN
C        convert E from cal/mole to Kelvin
        EFAC = 4.184  / RU_JOUL
     ELSEIF (EUNITS .EQ. ';KCAL';) THEN
C        convert E from kcal/mole to Kelvin
        EFAC = 4184.0 / RU_JOUL
     ELSEIF (EUNITS .EQ. ';JOUL';) THEN
C        convert E from Joules/mole to Kelvin
        EFAC = 1.00  / RU_JOUL
     ELSEIF (EUNITS .EQ. ';KJOU';) THEN
C        convert E from Kjoules/mole to Kelvin
        EFAC = 4000.0 / RU_JOUL
     ENDIF
     PAR(3,II) = PAR(3,II) * EFAC
     IF (NREV.GT.0 .AND. IREV(NREV).EQ.II)
    1    RPAR(3,NREV) = RPAR(3,NREV) * EFAC
     IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II)
    1    PFAL(3,NFAL) = PFAL(3,NFAL) * EFAC
C
     IF (AUNITS .EQ. ';MOLC';) THEN
        NSTOR = 0
        NSTOP = 0
        DO 50 N = 1, MAXSP
           IF (NU(N,II) .LT. 0) THEN
C              sum of stoichiometric coefficients of reactants
              NSTOR = NSTOR + ABS(NU(N,II))
           ELSEIF (NU(N,II) .GT. 0) THEN
C              sum of stoichiometric coefficients of products
              NSTOP = NSTOP + NU(N,II)
           ENDIF
  50    CONTINUE
C
        IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II) THEN
           IF (NSTOR.GT.0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
           NSTOR = NSTOR + 1
           IF (NSTOR.GT.0) PFAL(1,NFAL) = PFAL(1,NFAL)*AVAG**(NSTOR-1)
C
        ELSEIF (NTHB.GT.0 .AND. ITHB(NTHB).EQ.II) THEN
           NSTOR = NSTOR + 1
           NSTOP = NSTOP + 1
           IF (NSTOR.GT.0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
           IF (NREV.GT.0 .AND. IREV(NREV).EQ.II .AND. NSTOP.GT.0)
    1          RPAR(1,NREV) = RPAR(1,NREV) * AVAG**(NSTOP-1)
C
        ELSE
           IF (NSTOR .GT. 0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
           IF (NREV.GT.0 .AND. IREV(NREV).EQ.II .AND. NSTOP.GT.0)
    1          RPAR(1,NREV) = RPAR(1,NREV) * AVAG**(NSTOP-1)
        ENDIF
     ENDIF
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKBAL (MXSPEC, KSPEC, KCOEF, MDIM, MM, KCHRG, KNCF,
    1                  IERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION KSPEC(*), KCOEF(*), KNCF(MDIM,*), KCHRG(*)
     LOGICAL IERR
C
     IERR = .FALSE.
     KBAL = 0
     DO 50 N = 1, MXSPEC
        IF (KSPEC(N) .NE. 0)
    1   KBAL = KBAL + KCOEF(N)*KCHRG(KSPEC(N))
  50 CONTINUE
     IF (KBAL .NE. 0) IERR = .TRUE.
     DO 100 M = 1, MM
        MBAL = 0
        DO 80 N = 1, MXSPEC
           IF (KSPEC(N) .NE. 0)
    1      MBAL = MBAL + KCOEF(N)*KNCF(M,KSPEC(N))
  80    CONTINUE
        IF (MBAL .NE. 0) IERR = .TRUE.
100 CONTINUE
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKRBAL (MXSPEC, KSPEC, RCOEF, MDIM, MM, KCHRG, KNCF,
    1                   CKMIN, IERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION KSPEC(*), RCOEF(*), KNCF(MDIM,*), KCHRG(*)
     LOGICAL IERR
C
     IERR = .FALSE.
     SBAL = 0
     DO 50 N = 1, MXSPEC
        IF (KSPEC(N) .NE. 0)
    1   SBAL = SBAL + RCOEF(N)*KCHRG(KSPEC(N))
  50 CONTINUE
     IF (ABS(SBAL) .GT. CKMIN) IERR = .TRUE.
     DO 100 M = 1, MM
        SMBAL = 0
        DO 80 N = 1, MXSPEC
           IF (KSPEC(N) .NE. 0)
    1      SMBAL = SMBAL + RCOEF(N)*KNCF(M,KSPEC(N))
  80    CONTINUE
        IF (ABS(SMBAL) .GT. CKMIN) IERR = .TRUE.
100 CONTINUE
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKDUP (I, MAXSP, NS, NR, NU, NUNK, NFAL, IFAL, KFAL,
    1                  ISAME)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     DIMENSION NS(*), NR(*), NU(MAXSP,*), NUNK(MAXSP,*), IFAL(*),
    1          KFAL(*)
C
     ISAME = 0
     NRI = NR(I)
     NPI = ABS(NS(I)) - NR(I)
C
     DO 500 J = 1, I-1
C
        NRJ = NR(J)
        NPJ = ABS(NS(J)) - NR(J)
C
        IF (NRJ.EQ.NRI .AND. NPJ.EQ.NPI) THEN
C
           NSAME = 0
           DO 20 N = 1, MAXSP
              KI = NUNK(N,I)
              NI = NU(N,I)
C
              DO 15 L = 1, MAXSP
                 KJ = NUNK(L,J)
                 NJ = NU(L,J)
                 IF (NJ.NE.0 .AND. KJ.EQ.KI .AND. NJ.EQ.NI)
    1            NSAME = NSAME + 1
  15          CONTINUE
  20       CONTINUE
C
           IF (NSAME .EQ. ABS(NS(J))) THEN
              IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.I) THEN
                 DO 22 N = 1, NFAL-1
                    IF (J.EQ.IFAL(N) .AND. KFAL(N).EQ.KFAL(NFAL)) THEN
                       ISAME = J
                       RETURN
                    ENDIF
  22             CONTINUE
                 RETURN
              ENDIF
C
              ISAME = J
              RETURN
           ENDIF
        ENDIF
C
        IF (NPI.EQ.NRJ .AND. NPJ.EQ.NRI) THEN
C
           NSAME = 0
           DO 30 N = 1, MAXSP
              KI = NUNK(N,I)
              NI = NU(N,I)
C
              DO 25 L = 1, MAXSP
                 KJ = NUNK(L,J)
                 NJ = NU(L,J)
                 IF (NJ.NE.0 .AND. KJ.EQ.KI .AND. -NJ.EQ.NI)
    1            NSAME = NSAME + 1
  25          CONTINUE
  30       CONTINUE
C
           IF (NSAME.EQ.ABS(NS(J)) .AND.
    1          (NS(J).GT.0 .OR. NS(I).GT.0)) THEN
              IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.I) THEN
                 DO 32 N = 1, NFAL-1
                    IF (J.EQ.IFAL(N) .AND. KFAL(N).EQ.KFAL(NFAL)) THEN
                       ISAME = J
                       RETURN
                    ENDIF
  32             CONTINUE
                 RETURN
              ENDIF
C
              ISAME = J
              RETURN
           ENDIF
        ENDIF
C
500 CONTINUE
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE CKISUB (LINE, SUB, NSUB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) SUB(*), LINE
     NSUB = 0
C
     DO 5 N = 1, LEN(LINE)
       IF (ICHAR(LINE(N:N)) .EQ. 9) LINE(N:N) = '; ';
   5 CONTINUE
C
     IF (IPPLEN(LINE) .LE. 0) RETURN
C
     ILEN = ILASCH(LINE)
C
     NSTART = IFIRCH(LINE)
  10 CONTINUE
     ISTART = NSTART
     NSUB = NSUB + 1
     SUB(NSUB) = '; ';
C
     DO 100 I = ISTART, ILEN
        ILAST = INDEX(LINE(ISTART,'; ';) - 1
        IF (ILAST .GT. 0) THEN
           ILAST = ISTART + ILAST - 1
        ELSE
           ILAST = ILEN
        ENDIF
        SUB(NSUB) = LINE(ISTART:ILAST)
        IF (ILAST .EQ. ILEN) RETURN
C
        NSTART = ILAST + IFIRCH(LINE(ILAST+1:))
        I1 = INDEX(SUB(NSUB),';/';)
        IF (I1 .LE. 0) THEN
           IF (LINE(NSTART:NSTART) .NE. ';/';) GO TO 10
           NEND = NSTART + INDEX(LINE(NSTART+1:),';/';)
           IND = INDEX(SUB(NSUB),'; ';)
           SUB(NSUB)(IND:) = LINE(NSTART:NEND)
           IF (NEND .EQ. ILEN) RETURN
           NSTART = NEND + IFIRCH(LINE(NEND+1:))
           GO TO 10
        ENDIF
        I2 = INDEX(SUB(NSUB)(I1+1:),';/';)
        IF (I2 .GT. 0) GO TO 10
C
        NEND = NSTART + INDEX(LINE(NSTART+1:),';/';)
        IND = INDEX(SUB(NSUB),'; ';) + 1
        SUB(NSUB)(IND:) = LINE(NSTART:NEND)
        IF (NEND .EQ. ILEN) RETURN
        NSTART = NEND + IFIRCH(LINE(NEND+1:))
        GO TO 10
100 CONTINUE
     RETURN
     END
C----------------------------------------------------------------------C

rhong

SUBROUTINE IPNPAR (LINE, NPAR, IPAR, ISTART)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) LINE,IPAR
     ILEN = IPPLEN(LINE)
     ISTART = 0
     N = 0
     IF (ILEN.GT.0) THEN
        DO 40 I = ILEN, 1, -1
           ISTART = I
           IPAR = '; ';
           IPAR = LINE(ISTART:ILEN)
           IF (LINE(I:I).NE.'; ';) THEN
              IF (I .EQ. 1) RETURN
              IF (LINE(I-1:I-1) .EQ. '; ';) THEN
                 N = N + 1
                 IF (N .EQ. NPAR) RETURN
              ENDIF
           ENDIF
  40    CONTINUE
     ENDIF
     RETURN
     END
C----------------------------------------------------------------------C
     SUBROUTINE IPPARI(STRING, ICARD, NEXPEC, IVAL, NFOUND, IERR, LOUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) STRING
     CHARACTER ITEMP*80
     DIMENSION IVAL(*)
     CHARACTER *8 FMT(14)
     LOGICAL OKINCR
     IERR   = 0
     NFOUND = 0
     NEXP = IABS(NEXPEC)
     IE = ILASCH(STRING)
     IF (IE .EQ. 0) GO TO 500
     NC = 1
     OKINCR = .TRUE.
100   CONTINUE
     IF (STRING(NC:NC) .EQ. ';,';) THEN
        IF (OKINCR .OR. NC .EQ. IE) THEN
           NFOUND = NFOUND + 1
        ELSE
           OKINCR = .TRUE.
        ENDIF
C
        GO TO 450
     ENDIF
     IF (STRING(NC:NC) .EQ. '; ';) GO TO 450
     IBS = NC
160   CONTINUE
     NC = NC + 1
     IF (NC .GT. IE) GO TO 180
     IF (STRING(NC:NC) .EQ. '; ';)THEN
        OKINCR = .FALSE.
     ELSEIF (STRING(NC:NC) .EQ. ';,';)THEN
        OKINCR = .TRUE.
     ELSE
        GO TO 160
     ENDIF
180   CONTINUE
     NFOUND = NFOUND + 1
     IF (NFOUND .GT. NEXP) THEN
        IERR = 3
        GO TO 500
     ENDIF
C
     IES = NC - 1
     NCH = IES - IBS + 1
     DATA FMT/'; (I1)';, '; (I2)';, '; (I3)';, '; (I4)';, '; (I5)';,
    1   '; (I6)';, '; (I7)';, '; (I8)';, '; (I9)';, ';(I10)';,
    2   ';(I11)';, ';(I12)';, ';(I13)';, ';(I14)';/
     ITEMP = '; ';
     ITEMP = STRING(IBS:IES)
     READ (ITEMP(1:NCH), FMT(NCH), ERR = 400) IVAL(NFOUND)
     GO TO 450
400   CONTINUE
     IERR = 1
     GO TO 510
450   CONTINUE
     NC = NC + 1
     IF (NC .LE. IE) GO TO 100
C
500   CONTINUE
     IF (NEXPEC .GT. 0 .AND. NFOUND .LT. NEXP) IERR = 2
510   CONTINUE
C
     IF (IERR .EQ. 0 .OR. ICARD .LT. 0)RETURN
     IF (ICARD .NE. 0) WRITE (LOUT, ';(A,I3)';)
    1   ';!! ERROR IN DATA STATEMENT NUMBER';, ICARD
     IF (IERR .EQ. 1)
    1    WRITE (LOUT, ';(A)';)';SYNTAX ERROR, OR ILLEGAL value';
     IF (IERR .EQ. 2) WRITE (LOUT, ';(A,I2, A, I2)';)
    1   '; TOO FEW DATA ITEMS.  NUMBER FOUND = '; , NFOUND,
    2   ';  NUMBER EXPECTED = ';, NEXPEC
     IF (IERR .EQ. 3) WRITE (LOUT, ';(A,I2)';)
    1   '; TOO MANY DATA ITEMS.  NUMBER EXPECTED = ';, NEXPEC
     END
C
     SUBROUTINE IPPARR(STRING, ICARD, NEXPEC, RVAL, NFOUND, IERR, LOUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) STRING
     CHARACTER ITEMP*80
     DIMENSION RVAL(*)
     CHARACTER *8 FMT(22)
     LOGICAL OKINCR
C
C   FIRST EXECUTABLE STATEMENT  IPPARR
     IERR   = 0
     NFOUND = 0
     NEXP = IABS(NEXPEC)
     IE = ILASCH(STRING)
     IF (IE .EQ. 0) GO TO 500
     NC = 1
     OKINCR = .TRUE.
100   CONTINUE
     IF (STRING(NC:NC) .EQ. ';,';) THEN
        IF (OKINCR) THEN
           NFOUND = NFOUND + 1
        ELSE
           OKINCR = .TRUE.
        ENDIF
C
        GO TO 450
     ENDIF
     IF (STRING(NC:NC) .EQ. '; ';) GO TO 450
     IBS = NC
160   CONTINUE
     NC = NC + 1
     IF (NC .GT. IE) GO TO 180
     IF (STRING(NC:NC) .EQ. '; ';)THEN
        OKINCR = .FALSE.
     ELSEIF (STRING(NC:NC) .EQ. ';,';)THEN
        OKINCR = .TRUE.
     ELSE
        GO TO 160
     ENDIF
180   CONTINUE
     NFOUND = NFOUND + 1
     IF (NFOUND .GT. NEXP) THEN
        IERR = 3
        GO TO 500
     ENDIF
C
     DATA FMT/     '; (E1.0)';, '; (E2.0)';, '; (E3.0)';, '; (E4.0)';,
    1   '; (E5.0)';, '; (E6.0)';, '; (E7.0)';, '; (E8.0)';, '; (E9.0)';,
    2   ';(E10.0)';, ';(E11.0)';, ';(E12.0)';, ';(E13.0)';, ';(E14.0)';,
    3   ';(E15.0)';, ';(E16.0)';, ';(E17.0)';, ';(E18.0)';, ';(E19.0)';,
    4   ';(E20.0)';, ';(E21.0)';, ';(E22.0)';/
     IES = NC - 1
     NCH = IES - IBS + 1
     ITEMP = '; ';
     ITEMP = STRING(IBS:IES)
     READ (ITEMP(1:NCH), FMT(NCH), ERR = 400) RVAL(NFOUND)
     GO TO 450
400   CONTINUE
     WRITE (LOUT, 555) STRING(IBS:IES)
555 formAT (A)
     IERR = 1
     GO TO 510
450   CONTINUE
     NC = NC + 1
     IF (NC .LE. IE) GO TO 100
C
500   CONTINUE
     IF (NEXPEC .GT. 0 .AND. NFOUND .LT. NEXP) IERR = 2
510   CONTINUE
C
     IF (IERR .EQ. 0 .OR. ICARD .LT. 0) RETURN
     IF (ICARD .NE. 0) WRITE (LOUT, ';(A,I3)';)
    1   ';!! ERROR IN DATA STATEMENT NUMBER';, ICARD
     IF (IERR .EQ. 1)
    1   WRITE (LOUT, ';(A)';)';SYNTAX ERROR, OR ILLEGAL value';
     IF (IERR .EQ. 2) WRITE (LOUT, ';(A,I2, A, I2)';)
    1   '; TOO FEW DATA ITEMS.  NUMBER FOUND = '; , NFOUND,
    2   ';  NUMBER EXPECTED = ';, NEXPEC
     IF (IERR .EQ. 3) WRITE (LOUT, ';(A,I2)';)
    1   '; TOO MANY DATA ITEMS.  NUMBER EXPECTED = ';, NEXPEC
     END
C
     FUNCTION IFIRCH(STRING)
     CHARACTER* (*)STRING
C
C   FIRST EXECUTABLE STATEMENT IFIRCH
     NLOOP = LEN(STRING)
C
     IF (NLOOP .EQ. 0) THEN
        IFIRCH = 0
        RETURN
     ENDIF
C
     DO 100 I = 1, NLOOP
        IF (STRING(I:I) .NE. '; ';) GO TO 120
100   CONTINUE
C
     IFIRCH = 0
     RETURN
120   CONTINUE
     IFIRCH = I
     END
     FUNCTION ILASCH(STRING)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
      CHARACTER*(*) STRING
      NLOOP = LEN(STRING)
     IF (NLOOP.EQ.0) THEN
        ILASCH = 0
        RETURN
     ENDIF
C
     DO 100 I = NLOOP, 1, -1
        IF (STRING(I:I) .NE. '; ';) GO TO 120
100   CONTINUE
C
120   CONTINUE
     ILASCH = I
     END
     SUBROUTINE CKCOMP (IST, IRAY, II, I)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) IST, IRAY(*)
C
     I = 0
     DO 10 N = II, 1, -1
        IS1 = IFIRCH(IST)
        IS2 = ILASCH(IST)
        IR1 = IFIRCH(IRAY(N))
        IR2 = ILASCH(IRAY(N))
        IF ( IS2.GE.IS1 .AND. IS2.GT.0 .AND.
    1        IR2.GE.IR1 .AND. IR2.GT.0 .AND.
    2        IST(IS1:IS2).EQ.IRAY(N)(IR1:IR2) ) I=N
  10 CONTINUE
     RETURN
     END
     SUBROUTINE CKUNIT (LINE, AUNITS, EUNITS, IUNITS)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
     CHARACTER*(*) LINE, IUNITS, AUNITS, EUNITS
     CHARACTER*4 UPCASE
C
     AUNITS = '; ';
     EUNITS = '; ';
     IUNITS = '; ';
     LCHAR = ILASCH(LINE)
     DO 85 N = 1, ILASCH(LINE)-3
        IND = ILASCH(IUNITS)
        IF (EUNITS .EQ. '; ';) THEN
           IF (UPCASE(LINE(N, 4)     .EQ. ';CAL/';) THEN
              EUNITS = ';CAL/';
              IF (IUNITS .EQ. '; ';) THEN
                 IUNITS = ';E units cal/mole';
              ELSE
                 IUNITS(IND = ';, E units cal/mole';
              ENDIF
           ELSEIF (UPCASE(LINE(N, 4) .EQ. ';KCAL';) THEN
              EUNITS = ';KCAL';
              IF (IUNITS .EQ. '; ';) THEN
                 IUNITS = ';E units Kcal/mole';
              ELSE
                 IUNITS(IND:) = ';, E units Kcal/mole';
              ENDIF
           ELSEIF (UPCASE(LINE(N:), 4) .EQ. ';JOUL';) THEN
              EUNITS = ';JOUL';
              IF (IUNITS .EQ. '; ';) THEN
                 IUNITS = ';E units Joules/mole';
              ELSE
                 IUNITS(IND:) = ';, E units Joules/mole';
              ENDIF
           ELSEIF (UPCASE(LINE(N:), 4) .EQ. ';KJOU';) THEN
              EUNITS = ';KJOU';
              IF (IUNITS .EQ. '; ';) THEN
                 IUNITS = ';E units Kjoule/mole';
              ELSE
                 IUNITS(IND:) = ';, E units Kjoule/mole';
              ENDIF
           ELSEIF (UPCASE(LINE(N:), 4) .EQ. ';KELV';) THEN
              EUNITS = ';KELV';
              IF (IUNITS .EQ. '; ';) THEN
                 IUNITS = ';E units Kelvins';
              ELSE
                 IUNITS(IND:) = ';, E units Kelvins';
              ENDIF
           ENDIF
        ENDIF
        IF (AUNITS .EQ. '; ';) THEN
           IF (UPCASE(LINE(N:), 4) .EQ. ';MOLE';) THEN
              IF (N+4.LE.ILASCH(LINE) .AND.
    1                    UPCASE(LINE(N+4:),1).EQ.';C';) THEN
C
                 AUNITS = ';MOLC';
                 IF (IUNITS .EQ. '; ';) THEN
                    IUNITS = ';A units molecules';
                 ELSE
                     IUNITS(IND:) = ';, A units molecules';
                 ENDIF
              ELSE
                 AUNITS = ';MOLE';
                 IF (IUNITS .EQ. '; ';) THEN
                    IUNITS = ';A units mole-cm-sec-K';
                 ELSE
                    IUNITS(IND:) = ';, A units mole-cm-sec-K';
                 ENDIF
              ENDIF
           ENDIF
        ENDIF
  85 CONTINUE
C
     IF (AUNITS .EQ. '; ';) THEN
        AUNITS = ';MOLE';
        IND = ILASCH(IUNITS) + 1
        IF (IND .GT. 1) THEN
           IUNITS(IND:) = ';, A units mole-cm-sec-K';
        ELSE
           IUNITS(IND:) = '; A units mole-cm-sec-K';
        ENDIF
     ENDIF
C
     IF (EUNITS .EQ. '; ';) THEN
        EUNITS = ';CAL/';
        IND = ILASCH(IUNITS) + 1
        IF (IND .GT. 1) THEN
           IUNITS(IND:) = ';, E units cal/mole';
        ELSE
           IUNITS(IND:) = '; E units cal/mole';
        ENDIF
     ENDIF
C
     RETURN
     END
C
C----------------------------------------------------------------------C
C
     INTEGER FUNCTION IPPLEN (LINE)
C
C  BEGIN PROLOGUE
C
C  FUNCTION IPPLEN (LINE)
C     Returns the effective length of a character string, i.e.,
C     the index of the last character before an exclamation mark (!)
C     indicating a comment.
C
C  INPUT
C     LINE  - A character string.
C
C  OUTPUT
C     IPPLEN - The effective length of the character string.
C
C  END PROLOGUE
C
C*****precision > double
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
C*****END precision > double
C*****precision > single
C      IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
C*****END precision > single
C
     CHARACTER*(*) LINE
C
     IN = IFIRCH(LINE)
     IF (IN.EQ.0 .OR. LINE(IN:IN).EQ.';!';) THEN
        IPPLEN = 0
     ELSE
        IN = INDEX(LINE,';!';)
        IF (IN .EQ. 0) THEN
           IPPLEN = ILASCH(LINE)
        ELSE
           IPPLEN = ILASCH(LINE(:IN-1))
        ENDIF
     ENDIF
     RETURN
     END
C
     CHARACTER*(*) FUNCTION UPCASE(ISTR, ILEN)
     CHARACTER*(*) ISTR
     CHARACTER*1 LCASE(26), UCASE(26)
     DATA LCASE /';a';,';b';,';c';,';d';,';e';,';f';,';g';,';h';,';i';,';j';,';k';,';l';,';m';,
    1            ';n';,';o';,';p';,';q';,';r';,';s';,';t';,';u';,';v';,';w';,';x';,';y';,';z';/,
    2     UCASE /';A';,';B';,';C';,';D';,';E';,';F';,';G';,';H';,';I';,';J';,';K';,';L';,';M';,
    3            ';N';,';O';,'';,';Q';,';R';,';S';,';T';,';U';,';V';,';W';,';X';,';Y';,';Z';/
C
     UPCASE = '; ';
     UPCASE = ISTR(:ILEN)
     JJ = MIN (LEN(UPCASE), LEN(ISTR), ILEN)
     DO 10 J = 1, JJ
        DO 10 N = 1,26
           IF (ISTR(J:J) .EQ. LCASE(N)) UPCASE(J:J) = UCASE(N)
  10 CONTINUE
     RETURN
     END

xiaxiaangel

  厉害！顶一个，得到源代码的人怎么也不来谢一声？我看不懂，但为你的分享鼓掌！

araifan

多谢楼上上，不过在网页上复制下来的程序没办法用啊，调整前面的空格太麻烦了，麻烦直接贴.f附件吧

ycchen100

Do you want UNIX or Windows version?
cause the linkage is dealt differently.

tevinbbs

这是一个解释机理的主程序,基本没用,还需要求解具体问题的模块的主程序乐

ycchen100

下面引用由tevinbbs在 2007/08/31 00:54am 发表的内容：
这是一个解释机理的主程序,基本没用,还需要求解具体问题的模块的主程序乐

完全正确．所以才有Ｌｉｎｋ与计算平台的问题．
楼主是要 ＰＲＥＭＩＸ, ＯＰＰＤＩＦ,还是　ＯＰＰＦＬＯ的主程序？

araifan

我这里只有ＰＲＥＭＩＸ, ＯＰＰ的模块，不知道楼上还有没有其他部分

tevinbbs

我有senkin的一部分

ycchen100

PREMIX ver 2.55d Jan 1995
OPPDIF ver 3.1 Mar 1994
OPPFLO long time no use