|
|
马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？注册
x
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----------------------------------------------------------------------C
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
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';,';P';,';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 |
|
IP卡
狗仔卡
发表于 2005-5-6 21:14:06
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
显身卡
楼主
