?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
ENH: patchCloud: return pTraits<Type>::max for unfound points
[OpenFOAM-1.7.x.git] / applications / test / readCHEMKINIII / CHEMKINdata / ckinterp.f
blob01f41842204fd5855bedf850ddfbfdb6890aded1
1 C
2 PROGRAM CKINTP
3 C
4 C----------------------------------------------------------------------C
5 C VERSION 3.6
6 C CHANGES FROM VERSION 1.0
7 C 1. Changed from REAL*8 to DOUBLE PRECISION
8 C CHANGES FROM VERSION 1.1
9 C 1. Changed CHARACTER*100 to CHARACTER*80
10 C 2. Added THERMO "ALL" option
11 C 3. Write LENICK, LENRCK, LENCCK to binary file
12 C 4. Allow reaction species to end in '=' or '-'
13 C 5. Allow real values of elemental composition in THERMO cards
14 C 6. Allow upper/lower case input
15 C CHANGES FROM VERSION 1.2
16 C 1. Reaction delimiters are now "=" or "<=>" if reversible,
17 C " =>" if irreversible.
18 C 2. Fixed an error with IFIRCH(LINE) in IPPLEN
19 C CHANGES FROM VERSION 1.3
20 C 1. Add "unix" change blocks
21 C CHANGES FROM VERSION 1.4
22 C 1. Modify OPEN statements
23 C CHANGES FROM VERSION 1.5
24 C 1. Correct molecules to moles unit conversion
25 C 2. Correct UPCASE to avoid dimensioning errors
26 C CHANGES FROM VERSION 1.7
27 C 1. Further correction of molecules conversion for fall-off
28 C and third-body reactions
29 C CHANGES FOR VERSION 1.8
30 C 1. Change Subroutine CKUNIT to parse LINE instead of SUB(*)
31 C in order to correct misinterpretation of unit strings
32 C with slashes.
33 C CHANGES FOR VERSION 1.9
34 C 1. First record of binary file now consists of a character
35 C string version, precision, and logical error flag
36 C CHANGES FOR VERSION 2.0
37 C 1. Error in UPCASE could cause interpreter to ignore some
38 C keywords.
39 C CHANGES FOR VERSION 2.1
40 C 1. 10/18/90 (F. Rupley):
41 C Error in scaling the pre-exponential constants RPAR(3,*)
42 C where REV is declared, and FPAL(3,*) for fall-off reactions,
43 C as RPAR(3,II)*EFAC should read RPAR(3,NREV), and
44 C FPAL(3,II)*EFAC should read FPAL(3,NFAL).
45 C This error was introduced in CKINTERP.15 during refinement
46 C Dof units conversion routines.
47 C 2. Subroutine CKDUP modified to recognize that two reactions
48 C may be duplicate except for a third-body species in a
49 C fall-off reaction.
50 C CHANGES FOR VERSION 2.2
51 C 1. 11/14/90 (F. Rupley per M. Coltrin):
52 C Initialize variable NCHRG
53 C CHANGES FOR VERSION 2.3
54 C 1. In CKPREAC, error correction of 10/18/90 (above, V2.1).
55 C CHANGES FOR VERSION 2.4
56 C 1. Additional checking of TLO,TMID,THI for species -
57 C a) set initial values at -1.
58 C b) if user has not provided a TLO,TMID, or THI, use the
59 C values provided by THERMO.DAT.
60 C c) check that TLO < THI, TLO <= TMID <= THI
61 C CHANGES FOR VERSION 2.5
62 C 1. Need to get TLO,THI,TMID from database BEFORE reading
63 C user's THERMO data (unless THERMO ALL option is used)
64 C CHANGES FOR VERSION 2.6
65 C 1. LENRCK lengthened by II+NREV to reflect additional
66 C work space needed by CKRAT for a 4th parameter
67 C (perturbation factor).
68 C CHANGES FOR VERSION 2.7
69 C 1. Two otherwise duplicate reactions are unique if one
70 C is a third body reaction and the other not.
71 C CHANGES FOR VERSION 2.8
72 C 1. Change output format to print all 16 characters for
73 C a species name.
74 C CHANGES FOR VERSION 2.9 (2/24/92 F. Rupley)
75 C 1. Check that reverse (REV) parameters were given when
76 C RTL reverse Teller-Landauer parameters are given.
77 C 2. Add 2*II to length of real work space
78 C CHANGES FOR VERSION 3.0 (4/13/92 F. Rupley per M. Coltrin)
79 C 1. Correct logic in CKDUP, add argument to call list.
80 C CHANGES FOR VERSION 3.1 (2/24/93 F. Rupley per C. Westbrook,LLNL)
81 C 1. Problem in CKREAC for species starting with "M", where
82 C "+M" is signal for third-body.
83 C CHANGES FOR VERSION 3.2 (11/11/93 F. Rupley per T.U.Delft)
84 C 1. Ensure that SUBROUTINE CKUNIT does not check for units beyond
85 C end of LINE.
86 C CHANGES FOR VERSION 3.3 (1/26/94 F. Rupley per R. Kee)
87 C 1. Real stoichometric coefficients used in a supplemental way;
88 C NRNU total number of reactions using real stoichometry,
89 C IRNU array of reaction numbers, RNU real coefficients.
90 C CHANGES FOR VERSION 3.4 (3/15/94 F. Rupley)
91 C 1. DOS/PC compatibility effort includes adding file names to
92 C OPEN statements, removing unused variables in CALL lists,
93 C unusued but possibly initialized variables.
94 C CHANGES FOR VERSION 3.5 (4/19/94 F. Rupley)
95 C 1. Fix bug with index KSPEC(N) for CKBAL and CKRBAL.
96 C
97 C CKINTP interprets a formatted ASCII representation of a
98 C chemical reaction mechanism and creates the binary file LINK
99 C required by CHEMKIN. CKINTP is dimensioned as follows:
100 C
101 C MDIM = maximum number of elements in a problem; (10)
102 C KDIM = maximum number of species in a problem; (100)
103 C MAXTP= maximum number of temperatures used to fit (3)
104 C thermodynamic properties of species
105 C NPC = number of polynomial coefficients to fits (5)
106 C NPCP2= number of fit coefficients for a temperature range (7)
107 C IDIM = maximum number of reactions in a mechanism; (500)
108 C NPAR = number of Arrhenius parameters in a reaction; (3)
109 C NLAR = number of Landau-Teller parameters in a reaction; (2)
110 C NFAR = number of fall-off parameters in a reaction; (8)
111 C MAXSP= maximum number of species in a reaction (6)
112 C MAXTB= maximum number of third bodies for a reaction (10)
113 C LSYM = character string length of element and species names (16)
114 C
115 C User input is read from LIN (Unit15), a thermodynamic database
116 C is read from LTHRM (Unit17), printed output is assigned to LOUT
117 C (Unit16), and binary data is written to LINC (Unit25).
118 C
119 C REQUIRED ELEMENT INPUT: (Subroutine CKCHAR) (DIMENSION)
120 C
121 C The word 'ELEMENTS' followed by a list of element
122 C names, terminated by the word 'END';
123 C
124 C The resulting element data stored in LINK is:
125 C MM - integer number of elements found
126 C ENAME(*) - CHARACTER*(*) array of element names (MDIM)
127 C AWT(*) - real array of atomic weights; (MDIM)
128 C default atomic weights are those on
129 C atomic weight charts; if an element
130 C is not on the periodic chart, or if
131 C it is desirable to alter its atomic
132 C weight, this value must be included
133 C after the element name, enclosed by
134 C slashed, i.e., D/2.014/
135 C
136 C REQUIRED SPECIES INPUT: (Subroutine CKCHAR)
137 C
138 C The word 'SPECIES' followed by a list of species
139 C names, terminated by the word 'END';
140 C
141 C The resulting species data stored in LINK is:
142 C KK - integer number of species found
143 C KNAME(*) - CHARACTER*(*) array of species names (KDIM)
144 C
145 C OPTIONAL THERMODYNAMIC DATA: (Subroutine CKTHRM)
146 C (If this feature is not used, thermodynamic properties are
147 C obtained from a CHEMKIN database.) The format for this option
148 C is the word 'THERMO' followed by any number of 4-line data sets:
149 C
150 C Line 1: species name, optional comments, elemental composition,
151 C phase, T(low), T(high), T(mid), additional elemental
152 C composition, card number (col. 80);
153 C format(A10,A14,4(A2,I3),A1,E10.0,E10.0,E8.0,(A2,I3),I1)
154 C Line 2: coefficients a(1--5) for upper temperature range,
155 C card number (col. 80);
156 C format(5(e15.0),I1)
157 C Line 3: coefficients a(6--7) for upper temperature range,
158 C coefficients a(1--3) for lower temperature range,
159 C card number (col. 80);
160 C format(5(e15.0),I1)
161 C Line 4: coefficients a(4--7) for lower temperature range,
162 C card number (col. 80);
163 C format(4(e15.0),I1)
164 C
165 C End of THERMO data is indicated by 'END' line or new keyword.
166 C
167 C The resulting thermodynamic data stored in LINK are:
168 C WTM(*) - real array of molecular weights (KDIM)
169 C KNCF(*,*)- integer composition of species (MDIM,KDIM)
170 C KPHSE(*) - integer phase of a species; (KDIM)
171 C -1(solid), 0(gas), +1(liquid).
172 C KCHRG(*) - ionic charge of a species; (KDIM)
173 C = 0 except in presence/absence of electrons
174 C = +n in absence of n electrons
175 C = -n in presence of n electons
176 C NCHRG - integer number of species with KCHRG<>0
177 C NT(*) - array of number of temperatures used (KDIM)
178 C in fits
179 C T(*,*) - array of temperatures used in fits (MAXTP,KDIM)
180 C A(N,L,K) - Thermodynamic properties for (NPC+2,NTR,KDIM)
181 C species K consists of polynomial
182 C coefficients for fits to
183 C CP/R = SUM (A(N,L,K)*Temperature**(N-1), N=1,NPC+2)
184 C where T(L,K) <= Temperature < T(L+1,K),
185 C and,
186 C N=NPC+1 is formation enthalpy HO/R = A(NPC+1,L,K),
187 C N=NPC+2 is formation entropy SO/R = A(NPC+2,L,K)
188 C
189 C OPTIONAL REACTION INPUT:
190 C Reaction data is input after all ELEMENT, SPECIES and THERMO
191 C data in the following format:
192 C
193 C 1) (Subroutine CKREAC)
194 C The first line contains the keyword 'REACTIONS' and an
195 C optional description of units:
196 C
197 C 'MOLES' - (default), pre-exponential units are moles-sec-K;
198 C 'MOLECULES' - pre-exponential units are molecules and
199 C will be converted to moles.
200 C 'KELVINS' - activation energies are Kelvins, else the
201 C activation energies are converted to Kelvins;
202 C 'CAL/MOLE' - (default), activation energies are cal/mole;
203 C 'KCAL/MOLE' - activation energies are Kcal/mole;
204 C 'JOULES/MOLE' - activation energies are joules/mole;
205 C 'KJOULES/MOLE' - activation energies are Kjoules/mole.
206 C
207 C A description of each reaction is expected to follow.
208 C Required format for a reaction is a list of '+'-delimited
209 C reactants, followed by a list of '+'-delimited reactants,
210 C each preceded by its stoichiometric coefficient if greater
211 C than 1; separating the reactants from the products is a '='
212 C if reversible reaction, else a '=>'. Following the reaction
213 C string on the same line are the space-delimited Arrhenius
214 C coefficients.
215 C
216 C If the reaction contains a third body, this is indicated by
217 C by the presence of an 'M' as a reactant or product or both,
218 C and enhancement factors for third-bodies may be defined on
219 C additional lines as described in (2).
220 C
221 C If the reaction contains a radiation wavelength, this is
222 C indicated by the presence of an 'HV' either as a reactant
223 C or as a product. Unless otherwise defined on additional
224 C lines as described in (2), the value of the wavelength is
225 C -1.0 if a reactant or +1.0 if a product.
226 C
227 C If the reaction is a fall-off reaction, this is indicated
228 C either by a '(+M)' or a '(+KNAME(K))', and there must be
229 C additional lines as described in (2) to define fall-off
230 C parameters.
231 C
232 C 2) (Subroutine CKAUXL)
233 C Additional information for a reaction is given on lines
234 C immediately following the reaction description; this data
235 C will consist of a 'keyword' to denote the type of data,
236 C followed by a '/', then the required parameters for the
237 C keyword, followed by another '/'. There may be more than
238 C one keyword per line, and there may be any number of lines.
239 C The keywords and required parameters are as follows:
240 C
241 C KNAME(K)/efficiency value/ - species (K) is an enhanced
242 C third body in the reaction
243 C HV/wavelength/ - radiation wavelength parameter
244 C LT/val1 val2/ - Landau-Teller coefficients
245 C LOW/val1 val2 val3/ - low fall-off parameters
246 C TROE/val1 val2 val3 val4/ - Troe fall-off parameters;
247 C if val4 is omitted, a default
248 C parameter will be used
249 C SRI/val1 val2 val3 val4/ - SRI fall-off parameters;
250 C if val4 is omitted, a default
251 C parameter will be used
252 C (it is an error to have both LT and Fall-off defined)
253 C REV/par1 par2 par3/ - reverse parameters given
254 C RLT/val1 val2/ - Landau-Teller coefficients for reverse
255 C (it is an error if REV given and not RLT)
256 C
257 C The end of all reaction data is indicated by an 'END' card or
258 C <eof>.
259 C
260 C Resulting reaction data stored in LINC are:
261 C II - integer number of reactions found
262 C PAR(*,*) - array of real Arrhenius coefficients (NPAR,IDIM)
263 C NSPEC(*) - total number of species in a reaction (IDIM)
264 C if NSPEC < 0, reaction is irreversible
265 C NREAC(*) - number of reactants only (IDIM)
266 C NUNK(*,*) - array of species numbers for reaction (MAXSP,IDIM)
267 C NU(*,*) - array of stoichiometric coefficients (MAXSP,IDIM)
268 C of species in a reaction, negative=reactant,
269 C positive=product
270 C
271 C NWL - number of reactions with radiation wavelength
272 C IWL(*) - integer reaction numbers (IDIM)
273 C WL(*) - real radiation wavelengths (IDIM)
274 C
275 C NTHB - number of reactions with third bodies
276 C ITHB - integer reaction numbers (IDIM)
277 C NTBS(*) - total number of enhanced species for NTHB (IDIM)
278 C NKTB(*,*) - species numbers of enhanced species (MAXTB,IDIM)
279 C AIK(*,*) - enhancement factors (MAXTB,IDIM)
280 C
281 C NFAL - number of fall-off reactions
282 C IFAL(*) - integer reaction numbers (IDIM)
283 C KFAL(*) - integer species number for which
284 C concentrations are a factor in fall-off
285 C calculation
286 C IFOP(*) - integer fall-off type number (IDIM)
287 C = 0 if fall-off reaction is found
288 C = 1 for Lindemann form
289 C = 2 for 6-parameter Troe form
290 C = 3 for 7-parameter Troe form
291 C = 4 for SRI form
292 C PFAL(*,*) - fall-off parameters (NFAR,IDIM)
293 C
294 C NLAN - number of reactions with Landau-Teller
295 C ILAN - integer reaction numbers (IDIM)
296 C PLAN - Landau-Teller parameters (NLAR,IDIM)
297 C
298 C NREV - number of reactions with reverse parameters
299 C IREV(*) - integer reaction numbers (IDIM)
300 C RPAR(*,*) - parameters (NPAR,IDIM)
301 C
302 C NRLT - number of reactions with reverse parameters
303 C and Landau-Teller parameters
304 C IRLT(*) - integer reaction numbers (IDIM)
305 C RLAN(*,*) - reverse Teller-Laudauer parameters (NLAR,IDIM)
306 C
307 C----------------------------------------------------------------------C
308 C*****precision > double
309 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
310 C*****END precision > double
311 C*****precision > single
312 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
313 C*****END precision > single
314 C
315 PARAMETER (MDIM=50, KDIM=500, MKDIM=MDIM*KDIM, IDIM=500, LSYM=16,
316 1 NPAR=3, NPIDIM=IDIM*NPAR, NPC=5, NPCP2=NPC+2, MAXTP=3,
317 2 NTR=MAXTP-1, NKTDIM=NTR*NPCP2*KDIM, MAXSP=6, MAXTB=10,
318 3 NLAR=2, NSIDIM=MAXSP*IDIM, NTIDIM=MAXTB*IDIM,
319 4 NLIDIM=NLAR*IDIM, NFAR=8, NFIDIM=NFAR*IDIM,
320 5 NTDIM=KDIM*MAXTP, NIDIM=11*IDIM, LIN=15, LOUT=16,
321 6 LTHRM=17, LINC=25, CKMIN=1.0E-3, MAXORD=10,
322 7 NOIDIM=MAXORD*IDIM)
323 C
324 CHARACTER KNAME(KDIM)*(LSYM), ENAME(MDIM)*(LSYM), SUB(80)*80,
325 1 KEY(5)*4, LINE*80, IUNITS*80, AUNITS*4, EUNITS*4,
326 2 UPCASE*4, VERS*(LSYM), PREC*(LSYM)
327 C
328 DIMENSION AWT(MDIM), KNCF(MDIM,KDIM), WTM(KDIM), KPHSE(KDIM),
329 1 KCHRG(KDIM), A(NPCP2,NTR,KDIM), T(MAXTP,KDIM), NT(KDIM),
330 2 NSPEC(IDIM), NREAC(IDIM), NU(MAXSP,IDIM),
331 3 NUNK(MAXSP,IDIM), PAR(NPAR,IDIM), IDUP(IDIM),IREV(IDIM),
332 4 RPAR(NPAR,IDIM), ILAN(IDIM), PLAN(NLAR,IDIM),
333 5 IRLT(IDIM), RLAN(NLAR,IDIM), IWL(IDIM), WL(IDIM),
334 6 IFAL(IDIM), IFOP(IDIM), KFAL(IDIM), PFAL(NFAR,IDIM),
335 7 ITHB(IDIM),NTBS(IDIM),AIK(MAXTB,IDIM),NKTB(MAXTB,IDIM),
336 8 IRNU(IDIM), RNU(MAXSP,IDIM), IORD(IDIM),
337 9 KORD(MAXORD,IDIM), RORD(MAXORD,IDIM)
338 DIMENSION VALUE(5)
339 C
340 LOGICAL KERR, THERMO, ITHRM(KDIM)
341 C
342 C Initialize variables
343 C
344 DATA KEY/'ELEM','SPEC','THER','REAC','END'/, KERR/.FALSE./,
345 1 ITASK,NCHRG,MM,KK,II,NLAN,NFAL,NTHB,NREV,NRLT,NWL,
346 * NRNU,NORD/13*0/,
347 2 ENAME,AWT/MDIM*' ',MDIM*0.0/, THERMO/.TRUE./,
348 3 T/NTDIM*-1.0/, KNAME,WTM,NT,KPHSE,KCHRG,ITHRM
349 4 /KDIM*' ', KDIM*0.0, KDIM*3, KDIM*0, KDIM*0, KDIM*.FALSE./,
350 5 WL,IFOP,NTBS,IDUP /IDIM*0.0, IDIM*-1, IDIM*0, IDIM*0/,
351 6 NSPEC,NREAC,IREV,ILAN,IRLT,IWL,IFAL,KFAL,ITHB,IRNU,IORD
352 7 /NIDIM*0/
353 C
354 DATA NUNK,NU/NSIDIM*0, NSIDIM*0/, NKTB,AIK/NTIDIM*0,NTIDIM*-1.0/
355 DATA RNU/NSIDIM*0.0/, KORD/NOIDIM*0/, RORD/NOIDIM*0.0/
356 DATA PAR,RPAR/NPIDIM*0.0, NPIDIM*0.0/
357 DATA PLAN,RLAN/NLIDIM*0.0, NLIDIM*0.0/
358 DATA PFAL/NFIDIM*0.0/, KNCF/MKDIM*0.0/, A/NKTDIM*0.0/
359 C----------------------------------------------------------------------C
360 C
361 OPEN (LOUT, FORM='FORMATTED', STATUS='UNKNOWN', FILE='chem.out')
362 C
363 VERS = '3.6'
364 WRITE (LOUT, 15) VERS(:3)
365 15 FORMAT (/
366 1' CHEMKIN INTERPRETER OUTPUT: CHEMKIN-II Version ',A,' Apr. 1994'
367 C*****precision > double
368 2/' DOUBLE PRECISION'/)
369 PREC = 'DOUBLE'
370 C*****END precision > double
371 C*****precision > single
372 C 2/' SINGLE PRECISION'/)
373 C PREC = 'SINGLE'
374 C*****END precision > single
375 C
376 C START OF MECHANISM INTERPRETATION
377 C
378 OPEN (LIN, FORM='FORMATTED', STATUS='UNKNOWN', FILE='chem.inp')
379 C
380 100 CONTINUE
381 LINE = ' '
382 READ (LIN,'(A)',END=5000) LINE
383 105 CONTINUE
384 ILEN = IPPLEN(LINE)
385 IF (ILEN .EQ. 0) GO TO 100
386 C
387 CALL CKISUB (LINE(:ILEN), SUB, NSUB)
388 C
389 C IS THERE A KEYWORD?
390 C
391 CALL CKCOMP ( UPCASE(SUB(1), 4) , KEY, 5, NKEY)
392 IF (NKEY .GT. 0) ITASK = 0
393 C
394 IF (NKEY.EQ.1 .OR. NKEY.EQ.2) THEN
395 C
396 C ELEMENT OR SPECIES DATA
397 C
398 ITASK = NKEY
399 IF (NSUB .EQ. 1) GO TO 100
400 C
401 DO 25 N = 2, NSUB
402 SUB(N-1) = ' '
403 SUB(N-1) = SUB(N)
404 25 CONTINUE
405 NSUB = NSUB-1
406 C
407 ELSEIF (NKEY .EQ. 3) THEN
408 C
409 C THERMODYNAMIC DATA
410 C
411 IF (NSUB .GT. 1) THEN
412 IF ( UPCASE(SUB(2), 3) .EQ. 'ALL') THEN
413 THERMO = .FALSE.
414 READ (LIN,'(A)') LINE
415 CALL IPPARR (LINE, -1, 3, VALUE, NVAL, IER, LOUT)
416 IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
417 KERR = .TRUE.
418 WRITE (LOUT, 333)
419 ELSE
420 TLO = VALUE(1)
421 TMID = VALUE(2)
422 THI = VALUE(3)
423 ENDIF
424 ENDIF
425 ELSE
426 C
427 C USE THERMODYNAMIC DATABASE FOR DEFAULT TLO,TMID,THI
428 OPEN (LTHRM, FORM='FORMATTED', STATUS='UNKNOWN',
429 1 FILE='therm.dat')
430 C
431 READ (LTHRM,'(A)') LINE
432 READ (LTHRM,'(A)') LINE
433 CALL IPPARR (LINE, -1, 3, VALUE, NVAL, IER, LOUT)
434 IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
435 KERR = .TRUE.
436 WRITE (LOUT, 333)
437 ELSE
438 TLO = VALUE(1)
439 TMID = VALUE(2)
440 THI = VALUE(3)
441 ENDIF
442 CLOSE (LTHRM)
443 ENDIF
444 C
445 CALL CKTHRM (LIN, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
446 1 KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
447 2 THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
448 C
449 IF (.NOT. THERMO)
450 1 CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
451 2 KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
452 3 LOUT, KERR)
453 I1 = IFIRCH(LINE)
454 IF (UPCASE(LINE(I1:), 4) .EQ. 'REAC') GO TO 105
455 C
456 ELSEIF (NKEY .EQ. 4) THEN
457 C
458 ITASK = 4
459 C START OF REACTIONS; ARE UNITS SPECIFIED?
460 CALL CKUNIT (LINE(:ILEN), AUNITS, EUNITS, IUNITS)
461 C
462 IF (THERMO) THEN
463 C
464 C THERMODYNAMIC DATA
465 OPEN (LTHRM, FORM='FORMATTED', STATUS='UNKNOWN',
466 1 FILE='therm.dat')
467 READ (LTHRM,'(A)') LINE
468 READ (LTHRM,'(A)') LINE
469 CALL IPPARR (LINE, -1, 3, VALUE, NVAL, IER, LOUT)
470 IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
471 KERR = .TRUE.
472 WRITE (LOUT, 333)
473 ELSE
474 TLO = VALUE(1)
475 TMID = VALUE(2)
476 THI = VALUE(3)
477 ENDIF
478 CALL CKTHRM (LTHRM, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
479 1 KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
480 2 THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
481 CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
482 1 KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
483 2 LOUT, KERR)
484 THERMO = .FALSE.
485 CLOSE (LTHRM)
486 ENDIF
487 C
488 WRITE (LOUT, 1800)
489 GO TO 100
490 ENDIF
491 C
492 IF (ITASK .EQ. 1) THEN
493 C
494 C ELEMENT DATA
495 C
496 IF (MM .EQ. 0) THEN
497 WRITE (LOUT, 200)
498 WRITE (LOUT, 300)
499 WRITE (LOUT, 200)
500 ENDIF
501 C
502 IF (NSUB .GT. 0) THEN
503 M1 = MM +1
504 CALL CKCHAR (SUB, NSUB, MDIM, ENAME, AWT, MM, KERR, LOUT)
505 DO 110 M = M1, MM
506 IF (AWT(M) .LE. 0) CALL CKAWTM (ENAME(M), AWT(M))
507 WRITE (LOUT, 400) M,ENAME(M)(:4),AWT(M)
508 IF (AWT(M) .LE. 0) THEN
509 KERR = .TRUE.
510 WRITE (LOUT, 1000) ENAME(M)
511 ENDIF
512 110 CONTINUE
513 ENDIF
514 C
515 ELSEIF (ITASK .EQ. 2) THEN
516 C
517 C PROCESS SPECIES DATA
518 C
519 IF (KK .EQ. 0) WRITE (LOUT, 200)
520 IF (NSUB .GT. 0)
521 1 CALL CKCHAR (SUB, NSUB, KDIM, KNAME, WTM, KK, KERR, LOUT)
522 C
523 ELSEIF (ITASK .EQ. 4) THEN
524 C
525 C PROCESS REACTION DATA
526 C
527 IND = 0
528 DO 120 N = 1, NSUB
529 IND = MAX(IND, INDEX(SUB(N),'/'))
530 IF (UPCASE(SUB(N), 3) .EQ. 'DUP') IND = MAX(IND,1)
531 120 CONTINUE
532 IF (IND .GT. 0) THEN
533 C
534 C AUXILIARY REACTION DATA
535 C
536 CALL CKAUXL (SUB, NSUB, II, KK, KNAME, LOUT, MAXSP, NPAR,
537 1 NSPEC, NTHB, ITHB, NTBS, MAXTB, NKTB, AIK,
538 2 NFAL, IFAL, IDUP, NFAR, PFAL, IFOP, NLAN,
539 3 ILAN, NLAR, PLAN, NREV, IREV, RPAR, NRLT, IRLT,
540 4 RLAN, NWL, IWL, WL, KERR, NORD, IORD, MAXORD,
541 5 KORD, RORD, NUNK, NU, NRNU, IRNU, RNU)
542 C
543 ELSE
544 C
545 C THIS IS A REACTION STRING
546 C
547 IF (II .LT. IDIM) THEN
548 C
549 IF (II .GT. 0)
550 C
551 C CHECK PREVIOUS REACTION FOR COMPLETENESS
552 C
553 1 CALL CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR,
554 2 AUNITS, EUNITS, NREAC, NUNK, NU, KCHRG,
555 3 MDIM, MM, KNCF, IDUP, NFAL, IFAL, KFAL,
556 4 NFAR, PFAL, IFOP, NREV, IREV, NTHB, ITHB,
557 5 NLAN, ILAN, NRLT, IRLT, KERR, LOUT, NRNU,
558 6 IRNU, RNU, CKMIN)
559 C
560 C NEW REACTION
561 C
562 II = II+1
563 CALL CKREAC (LINE(:ILEN), II, KK, KNAME, LOUT, MAXSP,
564 1 NSPEC, NREAC, NUNK, NU, NPAR, PAR,
565 2 NTHB, ITHB, NFAL, IFAL, KFAL, NWL,
566 3 IWL, WL, NRNU, IRNU, RNU, KERR)
567 C
568 ELSE
569 WRITE (LOUT, 1070)
570 KERR = .TRUE.
571 ENDIF
572 C
573 ENDIF
574 ENDIF
575 GO TO 100
576 C
577 5000 CONTINUE
578 C
579 C END OF INPUT
580 C
581 IF (II .GT. 0) THEN
582 C
583 C CHECK FINAL REACTION FOR COMPLETENESS
584 C
585 CALL CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR, AUNITS,
586 1 EUNITS, NREAC, NUNK, NU, KCHRG, MDIM, MM,
587 2 KNCF, IDUP, NFAL, IFAL, KFAL, NFAR, PFAL, IFOP,
588 3 NREV, IREV, NTHB, ITHB, NLAN, ILAN, NRLT,
589 4 IRLT, KERR, LOUT, NRNU, IRNU, RNU, CKMIN)
590 C
591 C CHECK REACTIONS DECLARED AS DUPLICATES
592 C
593 DO 500 I = 1, II
594 IF (IDUP(I) .LT. 0) THEN
595 KERR = .TRUE.
596 WRITE (LOUT, 1095) I
597 ENDIF
598 500 CONTINUE
599 C
600 WRITE (LOUT, '(/1X,A)') ' NOTE: '//IUNITS(:ILASCH(IUNITS))
601 C
602 ELSEIF (THERMO) THEN
603 C
604 C THERE WAS NO REACTION DATA, MAKE SURE SPECIES DATA IS COMPLETE
605 OPEN (LTHRM, FORM='FORMATTED', STATUS='UNKNOWN',
606 1 FILE='therm.dat')
607 C
608 READ (LTHRM,'(A)') LINE
609 READ (LTHRM,'(A)') LINE
610 CALL IPPARR (LINE, -1, 3, VALUE, NVAL, IER, LOUT)
611 IF (NVAL .NE. 3 .OR. IER.NE.0) THEN
612 KERR = .TRUE.
613 WRITE (LOUT, 333)
614 ELSE
615 TLO = VALUE(1)
616 TMID = VALUE(2)
617 THI = VALUE(3)
618 ENDIF
619 CALL CKTHRM (LTHRM, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
620 1 KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
621 2 THI, T, NPCP2, A, ITHRM, KERR, LOUT, LINE)
622 CALL CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM, KPHSE,
623 1 KCHRG, NT, T, TLO, TMID, THI, KNCF, ITHRM,
624 2 LOUT, KERR)
625 CLOSE (LTHRM)
626 ENDIF
627 C
628 IF (KERR) THEN
629 C
630 WRITE (LOUT, '(//A)')
631 1 ' WARNING...THERE IS AN ERROR IN THE LINKING FILE'
632 DO 1150 K = 1, KK
633 IF (KCHRG(K) .NE. 0) NCHRG = NCHRG+1
634 1150 CONTINUE
635 STOP
636 ENDIF
637 C
638 LENICK = 1 + (3 + MM)*KK + (2 + 2*MAXSP)*II + NLAN + NRLT
639 1 + 3*NFAL + (2 + MAXTB)*NTHB + NREV + NWL + NRNU
640 2 + NORD*(1 + MAXORD)
641 LENCCK = MM + KK
642 LENRCK = 3 + MM + KK*(5 + MAXTP + NTR*NPCP2) + II*7 + NREV
643 1 + NPAR*(II + NREV) + NLAR*(NLAN + NRLT)
644 2 + NFAR*NFAL + MAXTB*NTHB + NWL + NRNU*MAXSP
645 3 + NORD*MAXORD
646 C
647 C OPEN LINKING FILE
648 C
649 OPEN (LINC, FORM='UNFORMATTED', STATUS='UNKNOWN',
650 1 FILE='chem.bin')
651 C
652 WRITE (LINC) VERS, PREC, KERR
653 WRITE (LINC) LENICK, LENRCK, LENCCK, MM, KK, II, MAXSP,
654 1 MAXTB, MAXTP, NPC, NPAR, NLAR, NFAR, NREV, NFAL,
655 2 NTHB, NLAN, NRLT, NWL, NCHRG, NRNU, NORD,
656 3 MAXORD, CKMIN
657 WRITE (LINC) (ENAME(M), AWT(M), M = 1, MM)
658 WRITE (LINC) (KNAME(K), (KNCF(M,K),M=1,MM), KPHSE(K),
659 1 KCHRG(K), WTM(K), NT(K), (T(L,K),L=1,MAXTP),
660 2 ((A(M,L,K), M=1,NPCP2), L=1,NTR), K = 1, KK)
661 C
662 IF (II .GT. 0) THEN
663 C
664 WRITE (LINC) (NSPEC(I), NREAC(I), (PAR(N,I), N = 1, NPAR),
665 1 (NU(M,I), NUNK(M,I), M = 1, MAXSP), I = 1, II)
666 C
667 IF (NREV .GT. 0) WRITE (LINC)
668 1 (IREV(N),(RPAR(L,N),L=1,NPAR),N=1,NREV)
669 C
670 IF (NFAL .GT. 0) WRITE (LINC)
671 1 (IFAL(N),IFOP(N),KFAL(N),(PFAL(L,N),L=1,NFAR), N = 1, NFAL)
672 C
673 IF (NTHB .GT. 0) WRITE (LINC)
674 1 (ITHB(N),NTBS(N),(NKTB(M,N),AIK(M,N),M=1,MAXTB),N=1,NTHB)
675 C
676 IF (NLAN .GT. 0) WRITE (LINC)
677 1 (ILAN(N), (PLAN(L,N), L = 1, NLAR), N = 1, NLAN)
678 C
679 IF (NRLT .GT. 0) WRITE (LINC)
680 1 (IRLT(N), (RLAN(L,N), L = 1, NLAR), N=1,NRLT)
681 C
682 IF (NWL .GT. 0) WRITE (LINC) (IWL(N), WL(N), N = 1, NWL)
683 C
684 IF (NRNU .GT. 0) WRITE (LINC)
685 C
686 C NRNU, total number of reactions with real stochio. coeff.
687 C
688 1 (IRNU(N), (RNU(M,N), M = 1, MAXSP), N = 1, NRNU)
689 C
690 C IRNU, indices of reaction numbers
691 C RNU, matrix of real stochiometric coefficients
692 C
693 IF (NORD .GT. 0) WRITE (LINC)
694 C
695 C NORD, total number of reactions which use "ORDER"
696 C
697 1 (IORD(N), (KORD(L,N), RORD(L,N), L=1, MAXORD), N=1,NORD)
698 C
699 C IORD, array of reaction numbers
700 C KORD, array of species numbers with "ORDER" specified,
701 C -K for forward species, K for reverse species
702 C RORD, array of order coefficients
703 ELSE
704 WRITE (LOUT, '(/A)')
705 1 ' WARNING...NO REACTION INPUT FOUND; ',
706 2 ' LINKING FILE HAS NO REACTION INFORMATION ON IT.'
707 ENDIF
708 C
709 WRITE (LOUT, '(///A)')
710 1 ' NO ERRORS FOUND ON INPUT...CHEMKIN LINKING FILE WRITTEN.'
711 C
712 WRITE (LOUT, '(/A,3(/A,I6))')
713 1 ' WORKING SPACE REQUIREMENTS ARE',
714 2 ' INTEGER: ',LENICK,
715 3 ' REAL: ',LENRCK,
716 4 ' CHARACTER: ',LENCCK
717 CLOSE (LINC)
718 CLOSE (LIN)
719 CLOSE (LOUT)
720 C
721 C----------------------------------------------------------------------C
722 C
723 C FORMATS
724 C
725 200 FORMAT (26X,20('-'))
726 300 FORMAT (26X,'ELEMENTS',5X,'ATOMIC',/26X,'CONSIDERED',3X,'WEIGHT')
727 333 FORMAT (/6X,'Error...no TLO,TMID,THI given for THERMO ALL...'/)
728 400 FORMAT (25X,I3,'. ',A4,G15.6)
729 C
730 1000 FORMAT (6X,'Error...no atomic weight for element ',A)
731 1070 FORMAT (6X,'Error...more than IDIM reactions...')
732 1095 FORMAT (6X,'Error...no duplicate declared for reaction no.',I3)
733 1800 FORMAT (///54X, '(k = A T**b exp(-E/RT))',/,
734 1 6X,'REACTIONS CONSIDERED',30X,'A',8X,'b',8X,'E',/)
735 C
736 STOP
737 END
738 C----------------------------------------------------------------------C
739 SUBROUTINE CKCHAR (SUB, NSUB, NDIM, STRAY, RAY, NN, KERR, LOUT)
740 C
741 C Extracts names and real values from an array of CHAR*(*)
742 C substrings; stores names in STRAY array, real values in RAY;
743 C i.e. can be used to store element and atomic weight data,
744 C species names, etc.
745 C
746 C Input: SUB(N),N=1,NSUB - array of CHAR*(*) substrings
747 C NSUB - number of substrings
748 C NDIM - size of STRAY,RAY arrays
749 C NN - actual number of STRAY found
750 C STRAY(N),N=1,NN - CHAR*(*) array
751 C RAY(N),N=1,NN - Real array
752 C LOUT - output unit for error messages
753 C Output: NN - incremented if more STRAY found
754 C STRAY(N),N=1,NN - incremented array of STRAY
755 C RAY(N),N=1,NN - incremented array of reals
756 C KERR - logical, .TRUE. = error in data
757 C
758 C F. Rupley, Div. 8245, 2/5/88
759 C----------------------------------------------------------------------C
760 C*****precision > double
761 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
762 C*****END precision > double
763 C*****precision > single
764 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
765 C*****END precision > single
766 C
767 DIMENSION RAY(*), PAR(1)
768 CHARACTER SUB(*)*(*), STRAY(*)*(*), ISTR*80, UPCASE*4
769 LOGICAL KERR
770 C
771 ILEN = LEN(STRAY(1))
772 C
773 DO 200 N = 1, NSUB
774 IF ( UPCASE(SUB(N), 3) .EQ. 'END') RETURN
775 ISTR = ' '
776 I1 = INDEX(SUB(N),'/')
777 IF (I1 .EQ .1) THEN
778 KERR = .TRUE.
779 WRITE (LOUT, 130) SUB(N)(:ILASCH(SUB(N)))
780 ELSE
781 IF (I1 .LE. 0) THEN
782 ISTR = SUB(N)
783 ELSE
784 ISTR = SUB(N)(:I1-1)
785 ENDIF
786 CALL CKCOMP (ISTR, STRAY, NN, INUM)
787 C
788 IF (INUM .GT. 0) THEN
789 WRITE (LOUT, 100) SUB(N)(:ILASCH(SUB(N)))
790 ELSE
791 IF (NN .LT. NDIM) THEN
792 IF (ISTR(ILEN+1:) .NE. ' ') THEN
793 WRITE (LOUT, 120) SUB(N)(:ILASCH(SUB(N)))
794 KERR = .TRUE.
795 ELSE
796 NN = NN + 1
797 STRAY(NN) = ' '
798 STRAY(NN) = ISTR(:ILEN)
799 IF (I1 .GT. 0) THEN
800 I2 = I1 + INDEX(SUB(N)(I1+1:),'/')
801 ISTR = ' '
802 ISTR = SUB(N)(I1+1:I2-1)
803 CALL IPPARR (ISTR, 1, 1, PAR, NVAL, IER, LOUT)
804 IF (IER .EQ. 0) THEN
805 RAY(NN) = PAR(1)
806 ELSE
807 KERR = .TRUE.
808 ENDIF
809 ENDIF
810 ENDIF
811 ELSE
812 WRITE (LOUT, 110) SUB(N)(:ILASCH(SUB(N)))
813 KERR = .TRUE.
814 ENDIF
815 ENDIF
816 ENDIF
817 200 CONTINUE
818 C
819 100 FORMAT (6X,'Warning...duplicate array element ignored...',A)
820 110 FORMAT (6X,'Error...character array size too small for ...',A)
821 120 FORMAT (6X,'Error...character array element name too long...',A)
822 130 FORMAT (6X,'Error...misplaced value...',A)
823 END
824 C----------------------------------------------------------------------C
825 SUBROUTINE CKAWTM (ENAME, AWT)
826 C
827 C Returns atomic weight of element ENAME.
828 C Input: ENAME - CHAR*(*) element name
829 C Output: AWT - real atomic weight
830 C
831 C F. Rupley, Div. 8245, 11/11/86
832 C----------------------------------------------------------------------C
833 C*****precision > double
834 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
835 C*****END precision > double
836 C*****precision > single
837 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
838 C*****END precision > single
839 C
840 PARAMETER (NATOM = 102)
841 DIMENSION ATOM(NATOM)
842 CHARACTER ENAME*(*), IATOM(NATOM)*2, UPCASE*2
843 C
844 DATA (IATOM(I),ATOM(I),I=1,40) /
845 *'H ', 1.00797, 'HE', 4.00260, 'LI', 6.93900, 'BE', 9.01220,
846 *'B ', 10.81100, 'C ', 12.01115, 'N ', 14.00670, 'O ', 15.99940,
847 *'F ', 18.99840, 'NE', 20.18300, 'NA', 22.98980, 'MG', 24.31200,
848 *'AL', 26.98150, 'SI', 28.08600, 'P ', 30.97380, 'S ', 32.06400,
849 *'CL', 35.45300, 'AR', 39.94800, 'K ', 39.10200, 'CA', 40.08000,
850 *'SC', 44.95600, 'TI', 47.90000, 'V ', 50.94200, 'CR', 51.99600,
851 *'MN', 54.93800, 'FE', 55.84700, 'CO', 58.93320, 'NI', 58.71000,
852 *'CU', 63.54000, 'ZN', 65.37000, 'GA', 69.72000, 'GE', 72.59000,
853 *'AS', 74.92160, 'SE', 78.96000, 'BR', 79.90090, 'KR', 83.80000,
854 *'RB', 85.47000, 'SR', 87.62000, 'Y ', 88.90500, 'ZR', 91.22000/
855 C
856 DATA (IATOM(I),ATOM(I),I=41,80) /
857 *'NB', 92.90600, 'MO', 95.94000, 'TC', 99.00000, 'RU',101.07000,
858 *'RH',102.90500, 'PD',106.40000, 'AG',107.87000, 'CD',112.40000,
859 *'IN',114.82000, 'SN',118.69000, 'SB',121.75000, 'TE',127.60000,
860 *'I ',126.90440, 'XE',131.30000, 'CS',132.90500, 'BA',137.34000,
861 *'LA',138.91000, 'CE',140.12000, 'PR',140.90700, 'ND',144.24000,
862 *'PM',145.00000, 'SM',150.35000, 'EU',151.96000, 'GD',157.25000,
863 *'TB',158.92400, 'DY',162.50000, 'HO',164.93000, 'ER',167.26000,
864 *'TM',168.93400, 'YB',173.04000, 'LU',174.99700, 'HF',178.49000,
865 *'TA',180.94800, 'W ',183.85000, 'RE',186.20000, 'OS',190.20000,
866 *'IR',192.20000, 'PT',195.09000, 'AU',196.96700, 'HG',200.59000/
867 C
868 DATA (IATOM(I),ATOM(I),I=81,NATOM) /
869 *'TL',204.37000, 'PB',207.19000, 'BI',208.98000, 'PO',210.00000,
870 *'AT',210.00000, 'RN',222.00000, 'FR',223.00000, 'RA',226.00000,
871 *'AC',227.00000, 'TH',232.03800, 'PA',231.00000, 'U ',238.03000,
872 *'NP',237.00000, 'PU',242.00000, 'AM',243.00000, 'CM',247.00000,
873 *'BK',249.00000, 'CF',251.00000, 'ES',254.00000, 'FM',253.00000,
874 *'D ',002.01410, 'E',5.45E-4/
875 C
876 CALL CKCOMP ( UPCASE(ENAME, 2), IATOM, NATOM, L)
877 IF (L .GT. 0) AWT = ATOM(L)
878 RETURN
879 END
880 C----------------------------------------------------------------------C
881 SUBROUTINE CKTHRM (LUNIT, MDIM, ENAME, MM, AWT, KNAME, KK, KNCF,
882 1 KPHSE, KCHRG, WTM, MAXTP, NT, NTR, TLO, TMID,
883 2 THI, T, NPCP2, A, ITHRM, KERR, LOUT, ISTR)
884 C
885 C Finds thermodynamic data and elemental composition for species
886 C Input: LUNIT - unit number for input of thermo properties
887 C MDIM - maximum number of elements allowed
888 C ENAME(M),M=1,MM - array of CHAR*(*) element names
889 C MM - total number of elements declared
890 C AWT(M),M=1,MM - array of atomic weights for elements
891 C KNAME(K),K=1,KK - array of CHAR*(*) species names
892 C KK - total number of species declared
893 C LOUT - output unit for messages
894 C NT(K),K=1,KK - number of temperature values
895 C NTR - number of temperature ranges
896 C Output: KNCF(M,K) - elemental composition of species
897 C KPHSE(K),K=1,KK - integer array, species phase
898 C KCHRG(K),K=1,KK - integer array of species charge
899 C =0, if no electrons,
900 C =(-1)*number of electrons present
901 C WTM(K),K=1,KK - array of molecular weights of species
902 C A(M,L,K)- array of thermodynamic coefficients
903 C T(N),N=1,NT - array of temperatures
904 C KERR - logical error flag
905 C----------------------------------------------------------------------C
906 C*****precision > double
907 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
908 C*****END precision > double
909 C*****precision > single
910 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
911 C*****END precision > single
912 C
913 DIMENSION WTM(*), NT(*), T(MAXTP,*), KPHSE(*), KNCF(MDIM,*),
914 1 KCHRG(*), A(NPCP2,NTR,*), AWT(*), VALUE(5)
915 CHARACTER ENAME(*)*(*), KNAME(*)*(*), LINE(4)*80, ELEM*16
916 CHARACTER UPCASE*4, ISTR*80, SUB(80)*80
917 LOGICAL KERR, ITHRM(*)
918 C
919 IF (MM.LE.0 .OR. KK.LE.0) WRITE (LOUT, 80)
920 C
921 GO TO 20
922 10 CONTINUE
923 ISTR = ' '
924 READ (LUNIT,'(A)',END=40) ISTR
925 20 CONTINUE
926 ILEN = IPPLEN(ISTR)
927 IF (ILEN .LE. 0) GO TO 10
928 C
929 CALL CKISUB (ISTR(:ILEN), SUB, NSUB)
930 CALL CKCOMP (SUB(1), KNAME, KK, K)
931 IF (K .EQ. 0) THEN
932 IF (UPCASE(SUB(1), 3) .EQ. 'END' .OR.
933 1 UPCASE(SUB(1), 4) .EQ. 'REAC') RETURN
934 GO TO 10
935 ENDIF
936 C
937 IF (ITHRM(K)) GO TO 10
938 ITHRM(K) = .TRUE.
939 LINE(1) = ' '
940 LINE(1) = ISTR
941 DO 25 L = 2, 4
942 LINE(L) = ' '
943 READ (LUNIT,'(A)',END=40) LINE(L)
944 25 CONTINUE
945 C
946 ICOL = 20
947 DO 60 I = 1, 5
948 ICOL = ICOL + 5
949 IF (I .EQ. 5) ICOL = 74
950 ELEM = LINE(1)(ICOL:ICOL+1)
951 IELEM = 0
952 C
953 IF (LINE(1)(ICOL+2:ICOL+4) .NE. ' ') THEN
954 CALL IPPARR
955 1 (LINE(1)(ICOL+2:ICOL+4), 0, 1, VALUE, NVAL, IER, LOUT)
956 IELEM = VALUE(1)
957 ENDIF
958 C
959 IF (ELEM.NE.' ' .AND. IELEM.NE.0) THEN
960 IF (UPCASE(ELEM, 1) .EQ. 'E')
961 1 KCHRG(K)=KCHRG(K)+IELEM*(-1)
962 CALL CKCOMP (ELEM, ENAME, MM, M)
963 IF (M .GT. 0) THEN
964 KNCF(M,K) = IELEM
965 WTM(K) = WTM(K) + AWT(M)*FLOAT(IELEM)
966 ELSE
967 WRITE (LOUT, 100) ELEM,KNAME(K)(:10)
968 KERR = .TRUE.
969 ENDIF
970 ENDIF
971 60 CONTINUE
972 C
973 IF (UPCASE(LINE(1)(45:),1) .EQ. 'L') KPHSE(K)=1
974 IF (UPCASE(LINE(1)(45:),1) .EQ. 'S') KPHSE(K)=-1
975 C
976 C-----Currently allows for three temperatures, two ranges;
977 C in future, NT(K) may vary, NTR = NT(K)-1
978 C
979 T(1,K) = TLO
980 IF (LINE(1)(46:55) .NE. ' ') CALL IPPARR
981 1 (LINE(1)(46:55), 0, 1, T(1,K), NVAL, IER, LOUT)
982 C
983 T(2,K) = TMID
984 IF (LINE(1)(66:73) .NE. ' ') CALL IPPARR
985 1 (LINE(1)(66:73), 0, 1, T(2,K), NVAL, IER, LOUT)
986 C
987 T(NT(K),K) = THI
988 IF (LINE(1)(56:65) .NE. ' ') CALL IPPARR
989 1 (LINE(1)(56:65), 0, 1, T(NT(K),K), NVAL, IER, LOUT)
990 C
991 READ (LINE(2)(:75),'(5E15.8)') (A(I,NTR,K),I=1,5)
992 READ (LINE(3)(:75),'(5E15.8)')
993 1 (A(I,NTR,K),I=6,7),(A(I,1,K),I=1,3)
994 READ (LINE(4)(:60),'(4E15.8)') (A(I,1,K),I=4,7)
995 GO TO 10
996 C
997 40 RETURN
998 80 FORMAT (6X,'Warning...THERMO cards misplaced will be ignored...')
999 100 FORMAT (6X,'Error...element...',A,'not declared for...',A)
1000 END
1001 C----------------------------------------------------------------------C
1002 SUBROUTINE CKREAC (LINE, II, KK, KNAME, LOUT, MAXSP, NSPEC, NREAC,
1003 1 NUNK, NU, NPAR, PAR, NTHB, ITHB,
1004 2 NFAL, IFAL, KFAL, NWL, IWL, WL,
1005 3 NRNU, IRNU, RNU, KERR)
1006 C
1007 C CKREAC parses the main CHAR*(*) line representing a gas-phase
1008 C reaction; first, the real Arrhenius parameters are located and
1009 C stored in PAR(N,I),N=1,NPAR, where I is the reaction number;
1010 C then a search is made over the reaction string:
1011 C
1012 C '=','<=>': reaction I is reversible;
1013 C '=>' : reaction I is irreversible;
1014 C
1015 C '(+[n]KNAME(K))': reaction I is a fall-off reaction;
1016 C NFAL is incremented, the total number of
1017 C fall-off reactions;
1018 C IFAL(NFAL)=I, KFAL(NFAL)=K;
1019 C this species is eliminated from consideration
1020 C as a reactant or product in this reaction.
1021 C
1022 C '(+M)' : reaction I is a fall-off reaction;
1023 C NFAL is incremented, IFAL(NFAL)=I, KFAL(NFAL)=0;
1024 C
1025 C '+[n]KNAME(K)': NSPEC(I) is incremented, the total number of
1026 C species for this reaction;
1027 C n is an optional stoichiometric coefficient
1028 C of KNAME(K), if omitted, n=1;
1029 C if this string occurs before the =/-,
1030 C NREAC(I) is incremented, the total number of
1031 C reactants for this reaction, NUNK(N,I)=K, and
1032 C NU(N,I) = -n, where N=1-3 is reserved for
1033 C reactants;
1034 C if this string occurs after the =/-,
1035 C NUNK(N,I) = K, and NU(N,I) = n, where N=4-6
1036 C is reserved for products;
1037 C
1038 C '+M' : I is a third-body reaction; NTHB is incremented, the
1039 C total number of third-body reactions, and ITHB(NTHB)=I.
1040 C
1041 C Input: LINE - a CHAR*(*) line (from data file)
1042 C II - the index of this reaction, and the total number
1043 C of reactions found so far.
1044 C KK - actual integer number of species
1045 C KNAME(K),K=1,KK - array of CHAR*(*) species names
1046 C LOUT - output unit for error messages
1047 C MAXSP - maximum number of species allowed in reaction
1048 C NPAR - number of parameters expected
1049 C A '!' will comment out a line, or remainder of the line.
1050 C
1051 C Output: NSPEC - total number of reactants+products in reaction
1052 C NREAC - number of reactants
1053 C NUNK - species numbers for the NSPEC species
1054 C NU - stoichiometric coefficients for the NSPEC spec.
1055 C NFAL - total number of fall-off reactions
1056 C IFAL - reaction numbers for the NFAL reactions
1057 C KFAL - 3rd body species numbers for the NFAL reactions
1058 C NTHB - total number of 3rd-body reactions
1059 C ITHB - reaction numbers for the NTHB reactions
1060 C NWL - number of radiation-enhanced reactions
1061 C IWL - reaction numbers for the NWL reactions
1062 C WL - radiation wavelengths for the NWL reactions
1063 C KERR - logical, .TRUE. = error in data file
1064 C
1065 C F. Rupley, Div. 8245, 5/13/86
1066 C----------------------------------------------------------------------C
1067 C*****precision > double
1068 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
1069 C*****END precision > double
1070 C*****precision > single
1071 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
1072 C*****END precision > single
1073 C
1074 DIMENSION NSPEC(*), NREAC(*), NUNK(MAXSP,*), NU(MAXSP,*),
1075 1 PAR(NPAR,*), IFAL(*), KFAL(*), ITHB(*), IWL(*), WL(*),
1076 2 IRNU(*), RNU(MAXSP,*), IPLUS(20)
1077 CHARACTER KNAME(*)*(*), LINE*(*), CNUM(11)*1, UPCASE*4
1078 CHARACTER*80 ISTR, IREAC, IPROD, ISPEC, INAME, ITEMP
1079 LOGICAL KERR, LTHB, LWL, LRSTO
1080 DATA CNUM/'.','0','1','2','3','4','5','6','7','8','9'/
1081 C
1082 LTHB = .FALSE.
1083 LWL = .FALSE.
1084 NSPEC(II) = 0
1085 NREAC(II) = 0
1086 C
1087 C----------Find NPAR real parameters------------------------
1088 C
1089 CALL IPNPAR (LINE, NPAR, ISTR, ISTART)
1090 CALL IPPARR (ISTR, 1, NPAR, PAR(1,II), NVAL, IER, LOUT)
1091 IF (IER .NE. 0) KERR = .TRUE.
1092 C
1093 C-----Remove blanks from reaction string
1094 C
1095 INAME = ' '
1096 ILEN = 0
1097 DO 10 I = 1, ISTART-1
1098 IF (LINE(I:I) .NE. ' ') THEN
1099 ILEN = ILEN+1
1100 INAME(ILEN:ILEN) = LINE(I:I)
1101 ENDIF
1102 10 CONTINUE
1103 C
1104 C-----Find reaction string, product string
1105 C
1106 I1 = 0
1107 I2 = 0
1108 DO 25 I = 1, ILEN
1109 IF (I1 .LE. 0) THEN
1110 IF (INAME(I:I+2) .EQ. '<=>') THEN
1111 I1 = I
1112 I2 = I+2
1113 IR = 1
1114 ELSEIF (INAME(I:I+1) .EQ. '=>') THEN
1115 I1 = I
1116 I2 = I+1
1117 IR = -1
1118 ELSEIF (I.GT.1 .AND. INAME(I:I).EQ.'='
1119 1 .AND. INAME(I-1:I-1).NE.'=') THEN
1120 I1 = I
1121 I2 = I
1122 IR = 1
1123 ENDIF
1124 ENDIF
1125 25 CONTINUE
1126 C
1127 IF (ILASCH(INAME).GE.45 .AND. I1.GT.0) THEN
1128 WRITE (LOUT, 1900) II,INAME(:I1-1),(PAR(N,II),N=1,NPAR)
1129 WRITE (LOUT, 1920) INAME(I1:)
1130 ELSE
1131 WRITE (LOUT, 1900) II,INAME(:45),(PAR(N,II),N=1,NPAR)
1132 ENDIF
1133 C
1134 IREAC = ' '
1135 IPROD = ' '
1136 IF (I1 .GT. 0) THEN
1137 IREAC = INAME(:I1-1)
1138 IPROD = INAME(I2+1:)
1139 ELSE
1140 C
1141 C-----did not find delimiter
1142 C
1143 WRITE (LOUT, 660)
1144 KERR = .TRUE.
1145 RETURN
1146 ENDIF
1147 C
1148 LRSTO = ((INDEX(IREAC,'.').GT.0) .OR. (INDEX(IPROD,'.').GT.0))
1149 IF (LRSTO) THEN
1150 NRNU = NRNU + 1
1151 IRNU(NRNU) = II
1152 ENDIF
1153 C
1154 IF (INDEX(IREAC,'=>').GT.0 .OR. INDEX(IPROD,'=>').GT.0) THEN
1155 C
1156 C-----more than one '=>'
1157 C
1158 WRITE (LOUT, 800)
1159 KERR = .TRUE.
1160 RETURN
1161 ENDIF
1162 C
1163 C-----Is this a fall-off reaction?
1164 C
1165 IF (INDEX(IREAC,'(+').GT.0 .OR. INDEX(IPROD,'(+').GT.0) THEN
1166 KRTB = 0
1167 KPTB = 0
1168 DO 300 J = 1, 2
1169 ISTR = ' '
1170 KTB = 0
1171 IF (J .EQ. 1) THEN
1172 ISTR = IREAC
1173 ELSE
1174 ISTR = IPROD
1175 ENDIF
1176 C
1177 DO 35 N = 1, ILASCH(ISTR)-1
1178 IF (ISTR(N:N+1) .EQ. '(+') THEN
1179 I1 = N+2
1180 I2 = I1 + INDEX(ISTR(I1:),')')-1
1181 IF (I2 .GT. I1) THEN
1182 IF (ISTR(I1:I2-1).EQ.'M' .OR.
1183 1 ISTR(I1:I2-1).EQ.'m') THEN
1184 IF (KTB .NE. 0) THEN
1185 WRITE (LOUT, 630)
1186 KERR = .TRUE.
1187 RETURN
1188 ELSE
1189 KTB = -1
1190 ENDIF
1191 ELSE
1192 CALL CKCOMP (ISTR(I1:I2-1), KNAME, KK, KNUM)
1193 IF (KNUM .GT. 0) THEN
1194 IF (KTB .NE. 0) THEN
1195 WRITE (LOUT, 630)
1196 KERR = .TRUE.
1197 RETURN
1198 ELSE
1199 KTB = KNUM
1200 ENDIF
1201 ENDIF
1202 ENDIF
1203 IF (KTB .NE. 0) THEN
1204 ITEMP = ' '
1205 IF (I1 .EQ. 1) THEN
1206 ITEMP = ISTR(I2+1:)
1207 ELSE
1208 ITEMP = ISTR(:I1-3)//ISTR(I2+1:)
1209 ENDIF
1210 IF (J .EQ. 1) THEN
1211 IREAC = ' '
1212 IREAC = ITEMP
1213 KRTB = KTB
1214 ELSE
1215 IPROD = ' '
1216 IPROD = ITEMP
1217 KPTB = KTB
1218 ENDIF
1219 ENDIF
1220 ENDIF
1221 ENDIF
1222 35 CONTINUE
1223 300 CONTINUE
1224 C
1225 IF (KRTB.NE.0 .OR. KPTB.NE.0) THEN
1226 C
1227 C does product third-body match reactant third-body
1228 C
1229 IF (KRTB.LE.0 .AND. KPTB.LE.0) THEN
1230 C
1231 NFAL = NFAL + 1
1232 IFAL(NFAL) = II
1233 KFAL(NFAL) = 0
1234 C
1235 LTHB = .TRUE.
1236 NTHB = NTHB + 1
1237 ITHB(NTHB) = II
1238 C
1239 ELSEIF (KRTB .EQ. KPTB) THEN
1240 NFAL = NFAL + 1
1241 IFAL(NFAL) = II
1242 KFAL(NFAL) = KRTB
1243 C
1244 ELSE
1245 C
1246 WRITE (LOUT, 640)
1247 KERR = .TRUE.
1248 RETURN
1249 ENDIF
1250 ENDIF
1251 ENDIF
1252 C
1253 C----------Find reactants, products-------------------------
1254 C
1255 DO 600 J = 1, 2
1256 ISTR = ' '
1257 LTHB = .FALSE.
1258 IF (J .EQ. 1) THEN
1259 ISTR = IREAC
1260 NS = 0
1261 ELSE
1262 ISTR = IPROD
1263 NS = 3
1264 ENDIF
1265 C
1266 C-----------store pointers to '+'-signs
1267 C
1268 NPLUS = 1
1269 IPLUS(NPLUS) = 0
1270 DO 500 L = 2, ILASCH(ISTR)-1
1271 IF (ISTR(L:L).EQ.'+') THEN
1272 NPLUS = NPLUS + 1
1273 IPLUS(NPLUS) = L
1274 ENDIF
1275 500 CONTINUE
1276 NPLUS = NPLUS + 1
1277 IPLUS(NPLUS) = ILASCH(ISTR)+1
1278 C
1279 NSTART = 1
1280 505 CONTINUE
1281 N1 = NSTART
1282 DO 510 N = NPLUS, N1, -1
1283 ISPEC = ' '
1284 ISPEC = ISTR(IPLUS(N1)+1 : IPLUS(N)-1)
1285 C
1286 IF (UPCASE(ISPEC, 1).EQ.'M' .AND.
1287 1 (ISPEC(2:2).EQ.' ' .OR. ISPEC(2:2).EQ.'+')) THEN
1288 IF (LTHB) THEN
1289 WRITE (LOUT, 900)
1290 KERR = .TRUE.
1291 RETURN
1292 ELSEIF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II) THEN
1293 WRITE (LOUT, 640)
1294 KERR = .TRUE.
1295 RETURN
1296 ELSE
1297 LTHB = .TRUE.
1298 IF (NTHB.EQ.0 .OR.
1299 1 (NTHB.GT.0.AND.ITHB(NTHB).NE.II)) THEN
1300 NTHB = NTHB + 1
1301 ITHB(NTHB) = II
1302 ENDIF
1303 IF (N .EQ. NPLUS) GO TO 600
1304 NSTART = N
1305 GO TO 505
1306 ENDIF
1307 C
1308 ELSEIF (UPCASE(ISPEC, 2) .EQ. 'HV') THEN
1309 IF (LWL) THEN
1310 WRITE (LOUT, 670)
1311 KERR = .TRUE.
1312 RETURN
1313 ELSE
1314 LWL = .TRUE.
1315 NWL = NWL + 1
1316 IWL(NWL) = II
1317 WL(NWL) = 1.0
1318 IF (J .EQ. 1) WL(NWL) = -1.0
1319 IF (N .EQ. NPLUS) GO TO 600
1320 NSTART = N
1321 GO TO 505
1322 ENDIF
1323 ENDIF
1324 C
1325 C-----------does this string start with a number?
1326 C
1327 IND = 0
1328 DO 334 L = 1, LEN(ISPEC)
1329 NTEST = 0
1330 DO 333 M = 1, 11
1331 IF (ISPEC(L:L) .EQ. CNUM(M)) THEN
1332 NTEST=M
1333 IND = L
1334 ENDIF
1335 333 CONTINUE
1336 IF (NTEST .EQ. 0) GO TO 335
1337 334 CONTINUE
1338 335 CONTINUE
1339 C
1340 RVAL = 1.0
1341 IVAL = 1
1342 IF (IND .GT. 0) THEN
1343 IF (LRSTO) THEN
1344 CALL IPPARR (ISPEC(:IND), 1, 1, RVAL, NVAL,
1345 1 IER, LOUT)
1346 ELSE
1347 CALL IPPARI (ISPEC(:IND), 1, 1, IVAL, NVAL,
1348 1 IER, LOUT)
1349 ENDIF
1350 IF (IER .EQ. 0) THEN
1351 ITEMP = ' '
1352 ITEMP = ISPEC(IND+1:)
1353 ISPEC = ' '
1354 ISPEC = ITEMP
1355 ELSE
1356 KERR = .TRUE.
1357 RETURN
1358 ENDIF
1359 ENDIF
1360 C
1361 CALL CKCOMP (ISPEC, KNAME, KK, KNUM)
1362 IF (KNUM .EQ. 0) THEN
1363 IF ((N-N1) .GT. 1) GO TO 510
1364 WRITE (LOUT, 680) ISPEC(:ILASCH(ISPEC))
1365 KERR = .TRUE.
1366 ELSE
1367 C
1368 C--------------a species has been found
1369 C
1370 IF (J .EQ. 1) THEN
1371 IVAL = -IVAL
1372 RVAL = -RVAL
1373 ENDIF
1374 C
1375 C--------------increment species coefficient count
1376 C
1377 NNUM = 0
1378 IF (LRSTO) THEN
1379 DO 110 K = 1, NS
1380 IF (KNUM.EQ.NUNK(K,II) .AND.
1381 1 RNU(K,NRNU)/RVAL.GT.0) THEN
1382 NNUM = K
1383 RNU(NNUM,NRNU) = RNU(NNUM,NRNU) + RVAL
1384 ENDIF
1385 110 CONTINUE
1386 ELSE
1387 DO 111 K = 1, NS
1388 IF (KNUM.EQ.NUNK(K,II) .AND.
1389 1 NU(K,II)/IVAL.GT.0) THEN
1390 NNUM=K
1391 NU(NNUM,II) = NU(NNUM,II) + IVAL
1392 ENDIF
1393 111 CONTINUE
1394 ENDIF
1395 C
1396 IF (NNUM .LE. 0) THEN
1397 C
1398 C-----------------are there too many species?
1399 C
1400 IF (J.EQ.1 .AND. NS.EQ.3) THEN
1401 WRITE (LOUT, 690)
1402 KERR = .TRUE.
1403 RETURN
1404 ELSEIF (J.EQ.2 .AND. NS.EQ.MAXSP) THEN
1405 WRITE (LOUT, 700)
1406 KERR = .TRUE.
1407 RETURN
1408 ELSE
1409 C
1410 C--------------------increment species count
1411 C
1412 NS = NS + 1
1413 NSPEC(II) = NSPEC(II)+1
1414 IF (J .EQ. 1) NREAC(II) = NS
1415 NUNK(NS,II) = KNUM
1416 IF (LRSTO) THEN
1417 RNU(NS,NRNU) = RVAL
1418 ELSE
1419 NU(NS,II) = IVAL
1420 ENDIF
1421 ENDIF
1422 ENDIF
1423 ENDIF
1424 IF (N .EQ. NPLUS) GO TO 600
1425 NSTART = N
1426 GO TO 505
1427 C
1428 510 CONTINUE
1429 600 CONTINUE
1430 C
1431 NSPEC(II) = IR*NSPEC(II)
1432 C
1433 630 FORMAT (6X,'Error...more than one fall-off declaration...')
1434 640 FORMAT (6X,'Error in fall-off declaration...')
1435 650 FORMAT (6X,'Error...reaction string not found...')
1436 660 FORMAT (6X,'Error in reaction...')
1437 670 FORMAT (6X,'Error in HV declaration...')
1438 680 FORMAT (6X,'Error...undeclared species...',A)
1439 690 FORMAT (6X,'Error...more than 3 reactants...')
1440 700 FORMAT (6X,'Error...more than 3 products...')
1441 800 FORMAT (6X,'Error in reaction delimiter...')
1442 900 FORMAT (6X,'Error in third-body declaration...')
1443 C 1900 FORMAT (I4,'. ',A,T51,E10.3,F7.3,F11.3)
1444 1900 FORMAT (I4,'. ', A, T53, 1PE8.2, 2X, 0PF5.1, 2X, F9.1)
1445 1920 FORMAT (6X,A)
1446 RETURN
1447 END
1448 C----------------------------------------------------------------------C
1449 SUBROUTINE CKAUXL (SUB, NSUB, II, KK, KNAME, LOUT, MAXSP, NPAR,
1450 1 NSPEC, NTHB, ITHB, NTBS, MAXTB, NKTB, AIK,
1451 2 NFAL, IFAL, IDUP, NFAR, PFAL, IFOP, NLAN,
1452 3 ILAN, NLAR, PLAN, NREV, IREV, RPAR, NRLT, IRLT,
1453 4 RLAN, NWL, IWL, WL, KERR, NORD, IORD, MAXORD,
1454 5 KORD, RORD, NUNK, NU, NRNU, IRNU, RNU)
1455 C
1456 C CKAUXL parses the auxiliary CHAR*(*) lines representing
1457 C additional options for a gas-phase reaction; data is stored
1458 C based on finding a 'keyword' followed by its required
1459 C parameters:
1460 C
1461 C KNAME(K)/val1/: this is an enhanced third-body;
1462 C
1463 C if ITHB(NTHB) <> I, this is an error, reaction I is not a
1464 C third-body reaction;
1465 C else NTBS(NTHB) is incremented,
1466 C AIK(NTBS(NTHB),NTHB) = K,
1467 C NKTB(NTBS(NTHB)),NTHB) = val1;
1468 C
1469 C (LOW,TROE, and SRI define fall-off data):
1470 C
1471 C LOW/val1 val2 val3/: PFAL(N,NFAL) = val(N),N=1,3;
1472 C
1473 C if IFAL(NFAL)<>I, this is an error, reaction I is not a
1474 C fall-off reaction;
1475 C if ILAN(NLAN)=I, this is an error, cannot have T-L numbers.
1476 C if IRLT(NRLT)=I, this is an error, "
1477 C if IREV(NREV)=I, this is an error, cannot declare reverse
1478 C parameters;
1479 C if IFOP(NFAL)>0, this is an error, LOW already declared;
1480 C else
1481 C IFOP(NFAL) = ABS(IFOP(NFAL))
1482 C
1483 C TROE/val1 val2 val3 [val4]/: PFAL(N,NFAL) = val(N),N=4,7;
1484 C
1485 C if IFAL(NFAL)<>I, this is an error, reaction I is not a
1486 C fall-off reaction;
1487 C if ILAN(NLAN)=I, this is an error, cannot have T-L numbers.
1488 C if IRLT(NRLT)=I, this is an error, "
1489 C if IREV(NREV)=I, this is an error, cannot declare reverse
1490 C parameters;
1491 C if ABS(IFOP(NFAL)).GT.1, this is an error,
1492 C else
1493 C if 3 TROE values, IFOP(NFAL) = 3*IFOP(NFAL);
1494 C if 4 TROE values, IFOP(NFAL) = 4*IFOP(NFAL);
1495 C
1496 C SRI/val1 val2 val3/: PFAL(N,NFAL) = val(N),N=4,6;
1497 C
1498 C if IFAL(NFAL)<>I, this is an error, reaction I is not a
1499 C fall-off reaction;
1500 C if ILAN(NLAN)=I, this is an error, cannot have T-L numbers.
1501 C if IRLT(NRLT)=I, this is an error, "
1502 C if IREV(NREV)=I, this is an error, cannot declare reverse
1503 C parameters;
1504 C if ABS(IFOP(NFAL))>1, this is an error;
1505 C else
1506 C if IFOP(NFAL)= 2*IFOP(NFAL);
1507 C
1508 C LT/val1 val2/:
1509 C if IFAL(NFAL)=I, this is an error, cannot have fall-off and
1510 C T-L numbers;
1511 C else increment NLAN, the number of T-L reactions,
1512 C ILAN(NLAN)=I, PLAN(N,NLAN)=val(N),N=1,2
1513 C if IREV(NREV)=I, need IRLT(NRLT)=I.
1514 C
1515 C REV[ERSE]/val1 val2 val3/ :
1516 C if IFAL(NFAL)=I, this is an error;
1517 C if IREV(NREV)=I, this is an error, REV already declared;
1518 C if NSPEC(I)<0, this an error, as I is irreversible;
1519 C else increment NREV, the number of reactions with reverse
1520 C parameters given,
1521 C IREV(NREV)=I, RPAR(N,NREV)=val(N),N=1,3;
1522 C if ILAN(NLAN)=I, need IRLT(NRLT)=I;
1523 C if IRLT(NRLT)=I, need ILAN(NRLT)=I.
1524 C
1525 C RLT/val1 val2/:
1526 C if IFAL(NFAL)=I, this is an error, cannot have fall-off and
1527 C T-L numbers;
1528 C if IRLT(NRLT)=I, this is an error, RLT already declared;
1529 C else increment NRLT, the number of reactions with BOTH
1530 C reverse parameters given, and T-L numbers;
1531 C IRLT(NRLT)=I, RLAN(N,NRLT)=val(N),N=1,2;
1532 C if IREV(NREV)<>I, need IREV(NREV)=I;
1533 C if ILAN(NREV)<>I, need ILAN(NLAN)=I;
1534 C
1535 C DUP[LICATE]:
1536 C This reaction is allowed to be duplicated.
1537 C
1538 C Input: LINE - CHAR*(*) auxiliary information string
1539 C KK - total number of species declared
1540 C KNAME- CHAR*(*) species names
1541 C LOUT - output unit for error messages
1542 C MAXSP- maximum third bodies allowed in a reaction
1543 C Output: NTHB - total number of reactions with third bodies
1544 C ITHB - array of third-body reaction numbers
1545 C AIK - non-zero third body enhancement factors
1546 C NKTB - array of species numbers for the third body
1547 C enchancement factors
1548 C NFAL - total number of fall-off reactions
1549 C IFAL - array of fall-off reaction numbers
1550 C IFOP - array of fall-off type
1551 C PFAL - fall-off parameters
1552 C NLAN - total number of Landau-Teller reactions
1553 C ILAN - array of T-L reaction numbers
1554 C NLAR - number of Landau-Teller numbers allowed
1555 C PLAN - array of Landau-Teller numbers
1556 C NRLT - total number of 'reverse' T-L reactions
1557 C IRLT - array of 'reverse' T-L reaction numbers
1558 C RLAN - array of 'reverse' Landau-Teller numbers
1559 C NWL - total number of radiation-enhanced reactions
1560 C IWL - array of radiation-enhanced reaction numbers
1561 C WL - array of wavelengths
1562 C KERR - logical, = .TRUE. if error found
1563 C F. Rupley, Div. 8245, 5/27/87
1564 C----------------------------------------------------------------------C
1565 C*****precision > double
1566 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
1567 C*****END precision > double
1568 C*****precision > single
1569 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
1570 C*****END precision > single
1571 C
1572 DIMENSION NSPEC(*), ITHB(*), NTBS(*), NKTB(MAXTB,*), IDUP(*),
1573 1 AIK(MAXTB,*), IFAL(*), IFOP(*), PFAL(NFAR,*),
1574 2 ILAN(*), PLAN(NLAR,*), IREV(*), RPAR(NPAR,*), IRLT(*),
1575 3 RLAN(NLAR,*), IWL(*), WL(*), VAL(1), IORD(*),
1576 4 KORD(MAXORD,*), RORD(MAXORD,*), NUNK(MAXSP,*),
1577 5 NU(MAXSP,*), IRNU(*), RNU(MAXSP,*)
1578 CHARACTER SUB(*)*(*), KNAME(*)*(*), KEY*80, RSTR*80, UPCASE*4,
1579 1 ISTR*80
1580 LOGICAL KERR, LLAN, LRLT, LTHB, LFAL, LTRO, LSRI, LWL, LREV,
1581 1 LFORD, LRORD
1582 C
1583 LTHB = (NTHB.GT.0 .AND. ITHB(NTHB).EQ.II)
1584 LFAL = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II)
1585 LWL = (NWL .GT.0 .AND. IWL(NWL) .EQ.II)
1586 LREV = (NREV.GT.0 .AND. IREV(NREV).EQ.II)
1587 LLAN = (NLAN.GT.0 .AND. ILAN(NLAN).EQ.II)
1588 LRLT = (NRLT.GT.0 .AND. IRLT(NRLT).EQ.II)
1589 LTRO = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).GT.2)
1590 LSRI = (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).EQ.2)
1591 C
1592 DO 500 N = 1, NSUB
1593 ILEN = ILASCH(SUB(N))
1594 KEY = ' '
1595 C
1596 IF ( UPCASE(SUB(N), 3) .EQ. 'DUP') THEN
1597 IDUP(II) = -1
1598 WRITE (LOUT, 4000)
1599 GO TO 500
1600 ELSE
1601 I1 = INDEX(SUB(N),'/')
1602 I2 = INDEX(SUB(N)(I1+1:),'/')
1603 IF (I1.LE.0 .OR. I2.LE.0) THEN
1604 KERR = .TRUE.
1605 WRITE (LOUT, 2090) SUB(N)(:ILEN)
1606 GO TO 500
1607 ENDIF
1608 KEY = SUB(N)(:I1-1)
1609 RSTR = ' '
1610 RSTR = SUB(N)(I1+1:I1+I2-1)
1611 ENDIF
1612 C
1613 IF (UPCASE(KEY, 3).EQ.'LOW' .OR.
1614 1 UPCASE(KEY, 4).EQ.'TROE'.OR.
1615 2 UPCASE(KEY, 3).EQ.'SRI') THEN
1616 C
1617 C FALL-OFF DATA
1618 C
1619 IF ((.NOT.LFAL) .OR. LLAN .OR. LRLT .OR. LREV) THEN
1620 KERR = .TRUE.
1621 IF (.NOT. LFAL) WRITE (LOUT, 1050) SUB(N)(:ILEN)
1622 IF (LLAN) WRITE (LOUT, 1060) SUB(N)(:ILEN)
1623 IF (LRLT) WRITE (LOUT, 1070) SUB(N)(:ILEN)
1624 IF (LREV) WRITE (LOUT, 1090) SUB(N)(:ILEN)
1625 ELSE
1626 C
1627 IF (UPCASE(KEY, 3) .EQ. 'LOW') THEN
1628 IF (IFOP(NFAL) .GT. 0) THEN
1629 WRITE (LOUT, 2000) SUB(N)(:ILEN)
1630 KERR = .TRUE.
1631 ELSE
1632 IFOP(NFAL) = ABS(IFOP(NFAL))
1633 CALL IPPARR (RSTR,1,3,PFAL(1,NFAL),NVAL,IER,LOUT)
1634 IF (IER .NE. 0) KERR = .TRUE.
1635 WRITE (LOUT, 3050) (PFAL(L,NFAL),L=1,3)
1636 ENDIF
1637 C
1638 ELSEIF (UPCASE(KEY, 4) .EQ. 'TROE') THEN
1639 IF (LTRO .OR. LSRI) THEN
1640 KERR = .TRUE.
1641 IF (LTRO) WRITE (LOUT, 2010) SUB(N)(:ILEN)
1642 IF (LSRI) WRITE (LOUT, 2030) SUB(N)(:ILEN)
1643 ELSE
1644 LTRO = .TRUE.
1645 CALL IPPARR (RSTR,1,-4,PFAL(4,NFAL),NVAL,IER,LOUT)
1646 IF (NVAL .EQ. 3) THEN
1647 IFOP(NFAL) = 3*IFOP(NFAL)
1648 WRITE (LOUT, 3080) (PFAL(L,NFAL),L=4,6)
1649 ELSEIF (NVAL .EQ. 4) THEN
1650 IFOP(NFAL) = 4*IFOP(NFAL)
1651 WRITE (LOUT, 3090) (PFAL(L,NFAL),L=4,7)
1652 ELSE
1653 WRITE (LOUT, 2020) SUB(N)(:ILEN)
1654 KERR = .TRUE.
1655 ENDIF
1656 ENDIF
1657 C
1658 ELSEIF (UPCASE(KEY, 3) .EQ. 'SRI') THEN
1659 IF (LTRO .OR. LSRI) THEN
1660 KERR = .TRUE.
1661 IF (LTRO) WRITE (LOUT, 2030) SUB(N)(:ILEN)
1662 IF (LSRI) WRITE (LOUT, 2040) SUB(N)(:ILEN)
1663 ELSE
1664 LSRI = .TRUE.
1665 IFOP(NFAL) = 2*IFOP(NFAL)
1666 CALL IPPARR (RSTR,1,-5,PFAL(4,NFAL),NVAL,IER,LOUT)
1667 IF (NVAL .EQ. 3) THEN
1668 PFAL(7,NFAL) = 1.0
1669 PFAL(8,NFAL) = 0.0
1670 WRITE (LOUT, 3060) (PFAL(L,NFAL),L=4,6)
1671 ELSEIF (NVAL .EQ. 5) THEN
1672 WRITE (LOUT, 3070) (PFAL(L,NFAL),L=4,8)
1673 ELSE
1674 WRITE (LOUT, 2020) SUB(N)(:ILEN)
1675 KERR = .TRUE.
1676 ENDIF
1677 ENDIF
1678 ENDIF
1679 ENDIF
1680 C
1681 ELSEIF (UPCASE(KEY, 3) .EQ. 'REV') THEN
1682 C
1683 C REVERSE ARRHENIUS PARAMETERS
1684 C
1685 IF (LFAL .OR. LREV .OR. NSPEC(II).LT.0) THEN
1686 KERR = .TRUE.
1687 IF (LFAL) WRITE (LOUT, 1090) SUB(N)(:ILEN)
1688 IF (LREV) WRITE (LOUT, 2050) SUB(N)(:ILEN)
1689 IF (NSPEC(II) .LT. 0) WRITE (LOUT, 2060) SUB(N)(:ILEN)
1690 ELSE
1691 LREV = .TRUE.
1692 NREV = NREV+1
1693 IREV(NREV) = II
1694 CALL IPPARR (RSTR,1,NPAR,RPAR(1,NREV),NVAL,IER,LOUT)
1695 IF (IER .NE. 0) KERR = .TRUE.
1696 WRITE (LOUT, 1900) ' Reverse Arrhenius coefficients:',
1697 1 (RPAR(L,NREV),L=1,3)
1698 ENDIF
1699 C
1700 ELSEIF (UPCASE(KEY, 3) .EQ. 'RLT') THEN
1701 C
1702 C REVERSE LANDAU-TELLER PARAMETERS
1703 C
1704 IF (LFAL .OR. LRLT .OR. NSPEC(II).LT.0) THEN
1705 KERR = .TRUE.
1706 IF (LFAL) WRITE (LOUT, 1070) SUB(N)(:ILEN)
1707 IF (LRLT) WRITE (LOUT, 2080) SUB(N)(:ILEN)
1708 IF (NSPEC(II) .LT. 0) WRITE (LOUT, 1080) SUB(N)(:ILEN)
1709 ELSE
1710 LRLT = .TRUE.
1711 NRLT = NRLT + 1
1712 IRLT(NRLT) = II
1713 CALL IPPARR (RSTR,1,NLAR,RLAN(1,NRLT),NVAL,IER,LOUT)
1714 IF (IER .NE. 0) KERR = .TRUE.
1715 WRITE (LOUT, 3040) (RLAN(L,NRLT),L=1,2)
1716 ENDIF
1717 C
1718 ELSEIF (UPCASE(KEY, 2) .EQ. 'HV') THEN
1719 C
1720 C RADIATION WAVELENGTH ENHANCEMENT FACTOR
1721 C
1722 IF (.NOT.LWL) THEN
1723 WRITE (LOUT, 1000) SUB(N)(:ILEN)
1724 KERR = .TRUE.
1725 ELSE
1726 CALL IPPARR (RSTR,1,1,VAL,NVAL,IER,LOUT)
1727 IF (IER .EQ. 0) THEN
1728 WL(NWL) = WL(NWL)*VAL(1)
1729 WRITE (LOUT, 3020) ABS(WL(NWL))
1730 ELSE
1731 WRITE (LOUT, 1000) SUB(N)(:ILEN)
1732 KERR = .TRUE.
1733 ENDIF
1734 ENDIF
1735 C
1736 ELSEIF (UPCASE(KEY, 2) .EQ. 'LT') THEN
1737 C
1738 C LANDAU-TELLER PARAMETERS
1739 C
1740 IF (LFAL .OR. LLAN) THEN
1741 KERR = .TRUE.
1742 IF (LFAL) WRITE (LOUT, 1060) SUB(N)(:ILEN)
1743 IF (LLAN) WRITE (LOUT, 2070) SUB(N)(:ILEN)
1744 ELSE
1745 LLAN = .TRUE.
1746 NLAN = NLAN + 1
1747 ILAN(NLAN) = II
1748 CALL IPPARR (RSTR,1,NLAR,PLAN(1,NLAN),NVAL,IER,LOUT)
1749 IF (IER .NE. 0) THEN
1750 WRITE (LOUT, 1010) SUB(N)(:ILEN)
1751 KERR = .TRUE.
1752 ENDIF
1753 WRITE (LOUT, 3000) (PLAN(L,NLAN),L=1,2)
1754 ENDIF
1755 C
1756 ELSEIF (UPCASE(KEY,4).EQ.'FORD' .OR.
1757 1 UPCASE(KEY,4).EQ.'RORD') THEN
1758 LFORD = (UPCASE(KEY,4) .EQ. 'FORD')
1759 LRORD = (UPCASE(KEY,4) .EQ. 'RORD')
1760 IF (NORD.EQ.0 .OR.(NORD.GT.0 .AND. IORD(NORD).NE.II)) THEN
1761 NORD = NORD + 1
1762 IORD(NORD) = II
1763 NKORD = 0
1764 C
1765 IF (NRNU.GT.0 .AND. IRNU(NRNU).EQ.II) THEN
1766 DO 111 L = 1, 6
1767 IF (NUNK(L,II) .NE. 0) THEN
1768 NKORD = NKORD + 1
1769 IF (RNU(L,NRNU) .LT. 0.0) THEN
1770 KORD(NKORD,NORD) = -NUNK(L,II)
1771 RORD(NKORD,NORD) = ABS(RNU(L,NRNU))
1772 ELSE
1773 KORD(NKORD,NORD) = NUNK(L,II)
1774 RORD(NKORD,NORD) = RNU(L,NRNU)
1775 ENDIF
1776 ENDIF
1777 111 CONTINUE
1778 ELSE
1779 DO 113 L = 1, 6
1780 IF (NUNK(L,II) .NE. 0) THEN
1781 NKORD = NKORD + 1
1782 IF (NU(L,II) .LT. 0) THEN
1783 KORD(NKORD,NORD) = -NUNK(L,II)
1784 RORD(NKORD,NORD) = IABS(NU(L,II))
1785 ELSE
1786 KORD(NKORD,NORD) = NUNK(L,II)
1787 RORD(NKORD,NORD) = NU(L,II)
1788 ENDIF
1789 ENDIF
1790 113 CONTINUE
1791 ENDIF
1792 ENDIF
1793 C
1794 CALL IPNPAR (RSTR, 1, ISTR, ISTART)
1795 IF (ISTART .GE. 1) THEN
1796 CALL IPPARR (ISTR, 1, 1, VAL, NVAL, IER, LOUT)
1797 CALL CKCOMP (RSTR(:ISTART-1), KNAME, KK, K)
1798 IF (LFORD) K = -K
1799 NK = 0
1800 DO 121 L = 1, MAXORD
1801 C
1802 IF (KORD(L,NORD).EQ.0) THEN
1803 NK = L
1804 GO TO 122
1805 ELSEIF (KORD(L,NORD).EQ.K) THEN
1806 IF (LFORD) THEN
1807 WRITE (LOUT,*)
1808 1' Warning...changing order for reactant...',
1809 2 KNAME(-K)
1810 ELSE
1811 WRITE (LOUT,*)
1812 1' Warning...changing order for product...',
1813 2 KNAME(K)
1814 ENDIF
1815 NK = L
1816 GO TO 122
1817 ENDIF
1818 121 CONTINUE
1819 122 CONTINUE
1820 KORD(NK,NORD) = K
1821 RORD(NK,NORD) = VAL(1)
1822 IF (LFORD) THEN
1823 WRITE (LOUT, 3015) KNAME(-K),VAL(1)
1824 ELSE
1825 WRITE (LOUT, 3016) KNAME(K),VAL(1)
1826 ENDIF
1827 ENDIF
1828 C
1829
1830 ELSE
1831 C
1832 C ENHANCED THIRD BODIES
1833 C
1834 CALL CKCOMP (KEY, KNAME, KK, K)
1835 IF (K .EQ. 0) THEN
1836 WRITE (LOUT, 1040) KEY(:ILASCH(KEY))
1837 KERR = .TRUE.
1838 ELSE
1839 IF (.NOT.LTHB) THEN
1840 KERR = .TRUE.
1841 WRITE (LOUT, 1020) SUB(N)(:ILEN)
1842 ELSE
1843 IF (NTBS(NTHB) .EQ. MAXTB) THEN
1844 KERR = .TRUE.
1845 WRITE (LOUT, 1030) SUB(N)(:ILEN)
1846 ELSE
1847 CALL IPPARR (RSTR, 1, 1, VAL, NVAL, IER, LOUT)
1848 IF (IER .EQ. 0) THEN
1849 WRITE (LOUT, 3010) KNAME(K),VAL(1)
1850 NTBS(NTHB) = NTBS(NTHB) + 1
1851 NKTB(NTBS(NTHB),NTHB) = K
1852 AIK(NTBS(NTHB),NTHB) = VAL(1)
1853 ELSE
1854 WRITE (LOUT, 1020) SUB(N)(:ILEN)
1855 KERR = .TRUE.
1856 ENDIF
1857 ENDIF
1858 ENDIF
1859 ENDIF
1860 ENDIF
1861 500 CONTINUE
1862 C
1863 C FORMATS
1864 C
1865 1000 FORMAT (6X,'Error in HV declaration...',A)
1866 1010 FORMAT (6X,'Error in LT declaration..',A)
1867 1020 FORMAT (6X,'Error in third body declaration...',A)
1868 1030 FORMAT (6X,'Error...more than MAXTB third bodies...',A)
1869 1040 FORMAT (6X,'Error...undeclared species...',A)
1870 1050 FORMAT (6X,'Error...this is not a fall-off reaction...',A)
1871 1060 FORMAT (6X,'Error...LT declared in fall-off reaction...',A)
1872 1070 FORMAT (6X,'Error...RLT declared in fall-off reaction...',A)
1873 1080 FORMAT (6X,'Error...RLT declared in irreversible reaction...',A)
1874 1090 FORMAT (6X,'Error...REV declared in fall-off reaction...',A)
1875 2000 FORMAT (6X,'Error...LOW declared more than once...',A)
1876 2010 FORMAT (6X,'Error...TROE declared more than once...',A)
1877 2020 FORMAT (6X,'Error in fall-off parameters...',A)
1878 2030 FORMAT (6X,'Error...cannot use both TROE and SRI...',A)
1879 2040 FORMAT (6X,'Error...SRI declared more than once...',A)
1880 2050 FORMAT (6X,'Error...REV declared more than once...',A)
1881 2060 FORMAT (6X,'Error...REV declared for irreversible reaction...',A)
1882 2070 FORMAT (6X,'Error...LT declared more than once...',A)
1883 2080 FORMAT (6X,'Error...RLT declared more than once...',A)
1884 2090 FORMAT (6X,'Error in auxiliary data...',A)
1885 3000 FORMAT (9X,'Landau-Teller parameters: B=',E12.5,', C=',E12.5)
1886 3010 FORMAT (9X,A16,' Enhanced by ',1PE12.3)
1887 3015 FORMAT (7X,A16,' Forward order ',1PE12.3)
1888 3016 FORMAT (7X,A16,' Reverse order ',1PE12.3)
1889 3020 FORMAT (9X,'Radiation wavelength (A): ',F10.2)
1890 C 1900 FORMAT (6X,A,T51,E10.3,F7.3,F11.3)
1891 1900 FORMAT (6X, A, T53, 1PE8.2, 2X, 0PF5.1, 2X, F9.1)
1892 3040 FORMAT (9X,'Reverse Landau-Teller parameters: B=',E12.5,
1893 1 ', C=',E12.5)
1894 3050 FORMAT (6X,'Low pressure limit:',3E13.5)
1895 3060 FORMAT (6X,'SRI centering: ',3E13.5)
1896 3070 FORMAT (6X,'SRI centering: ',5E13.5)
1897 3080 FORMAT (6X,'TROE centering: ',3E13.5)
1898 3090 FORMAT (6X,'TROE centering: ',4E13.5)
1899 4000 FORMAT (6X,'Declared duplicate reaction...')
1900 END
1901 C----------------------------------------------------------------------C
1902 SUBROUTINE CKPRNT (MDIM, MAXTP, MM, ENAME, KK, KNAME, WTM,
1903 1 KPHSE, KCHRG, NT, T, TLO, TMID, THI, KNCF,
1904 2 ITHRM, LOUT, KERR)
1905 C
1906 C Prints species interpreter output and checks for completeness.
1907 C----------------------------------------------------------------------C
1908 C*****precision > double
1909 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
1910 C*****END precision > double
1911 C*****precision > single
1912 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
1913 C*****END precision > single
1914 C
1915 DIMENSION WTM(*), KPHSE(*), KCHRG(*), T(MAXTP,*),
1916 1 NT(*), KNCF(MDIM,*), IPLUS(10)
1917 LOGICAL KERR, ITHRM(*)
1918 CHARACTER ENAME(*)*(*), KNAME(*)*(*), IPHSE(3)*1, INUM(10)*1
1919 DATA IPHSE/'S','G','L'/
1920 DATA INUM/'0','1','2','3','4','5','6','7','8','9'/
1921 C
1922 WRITE (LOUT, 400) (ENAME(M), M = 1, MM)
1923 WRITE (LOUT, 300)
1924 C
1925 DO 100 K = 1, KK
1926 C
1927 IF (T(1,K) .LT. 0.0) T(1,K) = TLO
1928 IF (T(2,K) .LT. 0.0) T(2,K) = TMID
1929 IF (T(3,K) .LT. 0.0) T(NT(K),K) = THI
1930 WRITE (LOUT, 500) K, KNAME(K), IPHSE(KPHSE(K)+2), KCHRG(K),
1931 1 WTM(K), T(1,K), T(NT(K),K), (KNCF(M,K),M=1,MM)
1932 IF (T(1,K) .GE. T(NT(K),K)) THEN
1933 KERR = .TRUE.
1934 WRITE (LOUT, 240)
1935 ENDIF
1936 IF (T(1,K) .GT. T(2,K)) THEN
1937 WRITE (LOUT, 250)
1938 KERR = .TRUE.
1939 ENDIF
1940 IF (T(NT(K),K) .LT. T(2,K)) THEN
1941 WRITE (LOUT, 260)
1942 KERR = .TRUE.
1943 ENDIF
1944 C
1945 C each species must have thermodynamic data
1946 C
1947 IF (.NOT. ITHRM(K)) THEN
1948 KERR = .TRUE.
1949 WRITE (LOUT, 200)
1950 ENDIF
1951 C
1952 C a species cannot start with a number
1953 C
1954 CALL CKCOMP (KNAME(K)(:1), INUM, 10, I)
1955 IF (I .GT. 0) THEN
1956 KERR = .TRUE.
1957 WRITE (LOUT, 210)
1958 ENDIF
1959 C
1960 C if '+' sign is used in a species name,
1961 C examples of legal species symbols with + are:
1962 C OH(+)2, OH(+2), OH+, OH++, OH+++, OH(+), OH(++),
1963 C OH[+OH], OH2+, OH+2
1964 C
1965 C examples of illegal species symbols with + are:
1966 C +OH (symbol starts with a +, this will cause
1967 C confusion in a reaction)
1968 C OH(+OH) (symbol in parentheses is another species-
1969 C this arrangement is reserved for a fall-off
1970 C reaction)
1971 C OH+OH (plus delimits other species names, this
1972 C will cause confusion in a reaction)
1973 C
1974 NPLUS = 0
1975 DO 50 N = 1, ILASCH(KNAME(K))
1976 IF (KNAME(K)(N:N) .EQ. '+') THEN
1977 NPLUS = NPLUS + 1
1978 IPLUS(NPLUS) = N
1979 ENDIF
1980 50 CONTINUE
1981 DO 60 N = 1, NPLUS
1982 I1 = IPLUS(N)
1983 IF (I1 .EQ. 1) THEN
1984 WRITE (LOUT, 220)
1985 KERR = .TRUE.
1986 ELSE
1987 C
1988 C is there another species name in parentheses
1989 C
1990 IF (KNAME(K)(I1-1:I1-1) .EQ. '(') THEN
1991 I1 = I1 + 1
1992 I2 = I1 + INDEX(KNAME(K)(I1:),')')-1
1993 IF (I2 .GT. I1) THEN
1994 CALL CKCOMP (KNAME(K)(I1:I2-1), KNAME, KK, KNUM)
1995 IF (KNUM .GT. 0) THEN
1996 WRITE (LOUT, 230)
1997 KERR = .TRUE.
1998 ENDIF
1999 ENDIF
2000 ENDIF
2001 C
2002 C is there another species name after a +
2003 C
2004 I1 = I1 + 1
2005 IF (N .LT. NPLUS) THEN
2006 DO 55 L = N+1, NPLUS
2007 I2 = IPLUS(L)
2008 IF (I2 .GT. I1) THEN
2009 CALL CKCOMP (KNAME(K)(I1:I2-1),KNAME,KK,KNUM)
2010 IF (KNUM .GT. 0) THEN
2011 WRITE (LOUT, 230)
2012 KERR = .TRUE.
2013 ENDIF
2014 ENDIF
2015 55 CONTINUE
2016 ENDIF
2017 C
2018 I2 = ILASCH(KNAME(K))
2019 IF (I2 .GE. I1) THEN
2020 CALL CKCOMP (KNAME(K)(I1:I2), KNAME, KK, KNUM)
2021 IF (KNUM .GT. 0) THEN
2022 WRITE (LOUT, 230)
2023 KERR = .TRUE.
2024 ENDIF
2025 ENDIF
2026 ENDIF
2027 60 CONTINUE
2028 C
2029 100 CONTINUE
2030 WRITE (LOUT, 300)
2031 RETURN
2032 C
2033 200 FORMAT (6X,'Error...no thermodynamic properties for species')
2034 210 FORMAT (6X,'Error...species starts with a number')
2035 220 FORMAT (6X,'Error...species starts with a plus')
2036 230 FORMAT (6X,'Error...illegal + in species name')
2037 240 FORMAT (6X,'Error...High temperature must be < Low temperature')
2038 250 FORMAT (6X,'Error...Low temperature must be <= Mid temperature')
2039 260 FORMAT (6X,'Error...High temperature must be => Mid temperature')
2040 300 FORMAT (1X,79('-'))
2041 C 400 FORMAT (1X,79('-'),/21X,'C',/18X,'P',2X,'H',/18X,'H',2X,'A',
2042 C 1 /18X,'A',2X,'R',/1X,'SPECIES',10X,'S',2X,'G',2X,
2043 C 2 'MOLECULAR',3X,'TEMPERATURE',4X,'ELEMENT COUNT',/1X,
2044 C 3 'CONSIDERED',7X,'E',2X,'E',2X,'WEIGHT',6X,'LOW',5X,
2045 C 4 'HIGH',3X,15(A3),/1X,79('-'))
2046 C 500 FORMAT (I4,'. ',A10,2X,A1,I3,F11.5,2(F8.1),15(I3))
2047 C
2048 400 FORMAT (1X,79('-'),/T26,'C',/T24,'P H',/T24,'H A',/T24,'A R',
2049 1 /1X,'SPECIES',T24,'S G',T28,'MOLECULAR',T38,'TEMPERATURE',
2050 2 T52,'ELEMENT COUNT',
2051 3 /1X,'CONSIDERED',T24,'E E',T28,'WEIGHT',T38,'LOW',
2052 4 T45,'HIGH',T52,15(A3))
2053 500 FORMAT (1X,I3,'. ',A16,T24,A1,T26,I1,T28,F9.5,T38,F6.1,T45,F6.1,
2054 1 T51,15(I3))
2055 END
2056 C----------------------------------------------------------------------C
2057 SUBROUTINE CPREAC (II, MAXSP, NSPEC, NPAR, PAR, RPAR, AUNITS,
2058 1 EUNITS, NREAC, NUNK, NU, KCHRG, MDIM, MM, KNCF,
2059 2 IDUP, NFAL, IFAL, KFAL, NFAR, PFAL, IFOP, NREV,
2060 3 IREV, NTHB, ITHB, NLAN, ILAN, NRLT, IRLT, KERR,
2061 4 LOUT, NRNU, IRNU, RNU, CKMIN)
2062 C
2063 C Prints reaction interpreter output and checks for reaction
2064 C balance, duplication, and missing data in 'REV' reactions;
2065 C correct units of Arrhenius parameters
2066 C
2067 C Input: II - the index number of the reaction
2068 C MAXSP - maximum number of species allowed in a reaction
2069 C NSPEC - array of the number of species in the reactions
2070 C NPAR - the number of Arrhenius parameters required
2071 C PAR - matrix of Arrhenius parameters for the reactions
2072 C RPAR - matrix of reverse Arrhenius parameters for the
2073 C reactions which declared them
2074 C AUNITS - character string which describes the input units
2075 C of A, the pre-exponential factor PAR(1,I)
2076 C EUNITS - character string which describes the input units
2077 C of E, the activation energy PAR(3,I)
2078 C NREAC - array of the number of reactants in the reactions
2079 C NUNK - matrix of the species numbers of the reactants
2080 C and products in the reactions
2081 C NU - matrix of the stoichiometric coefficients of the
2082 C reactants and products in the reactions
2083 C KCHRG - array of the electronic charges of the species
2084 C MDIM - the maximum number of elements allowed
2085 C MM - the actual number of elements declared
2086 C KNCF - matrix of elemental composition of the species
2087 C IDUP - array of integer flags to indicate duplicate
2088 C reactions
2089 C NFAL - total number of reactions with fall-off
2090 C IFAL - array of the NFAL reaction numbers
2091 C NFAR - maximum number of fall-off parameters allowed
2092 C PFAL - matrix of fall-off parameters for the NFAL
2093 C reactions
2094 C IFOP - array of integer fall-off types for the NFAL
2095 C reactions
2096 C NREV - total number of reactions with reverse parameters
2097 C IREV - array of the NREV reaction numbers
2098 C NTHB - total number of reactions with third-bodies
2099 C ITHB - array of the NTHB reaction numbers
2100 C NLAN - total number of reactions with Landauer-Teller
2101 C parameters
2102 C ILAN - array of the NLAN reaction numbers
2103 C NRLT - total number of reactions with reverse
2104 C Landauer-Teller parameters
2105 C IRLT - array of the NRLT reaction numbers
2106 C KERR - logical error flag
2107 C LOUT - unit number for output messages
2108 C
2109 C----------------------------------------------------------------------C
2110 C
2111 C*****precision > double
2112 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2113 C*****END precision > double
2114 C*****precision > single
2115 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2116 C*****END precision > single
2117 C
2118 DIMENSION NSPEC(*), PAR(NPAR,*), RPAR(NPAR,*), NREAC(*),
2119 1 NUNK(MAXSP,*), NU(MAXSP,*), KCHRG(*), KNCF(MDIM,*),
2120 2 IDUP(*), IFAL(*), KFAL(*), PFAL(NFAR,*), IFOP(*),
2121 3 IREV(*), ITHB(*), ILAN(*), IRLT(*), IRNU(*),
2122 4 RNU(MAXSP,*)
2123 CHARACTER*(*) AUNITS, EUNITS
2124 LOGICAL IERR,KERR,LREV,LLAN,LRLT
2125 C
2126 IF (NRNU.GT.0 .AND. (II.EQ.IRNU(NRNU))) THEN
2127 CALL CKRBAL (MAXSP, NUNK(1,II), RNU(1,NRNU), MDIM, MM, KCHRG,
2128 1 KNCF, CKMIN, IERR)
2129 ELSE
2130 CALL CKBAL (MAXSP, NUNK(1,II), NU(1,II), MDIM, MM, KCHRG, KNCF,
2131 1 IERR)
2132 ENDIF
2133 C
2134 IF (IERR) THEN
2135 KERR = .TRUE.
2136 WRITE (LOUT, 1060)
2137 ENDIF
2138 C
2139 CALL CKDUP (II, MAXSP, NSPEC, NREAC, NU, NUNK, NFAL, IFAL, KFAL,
2140 1 ISAME)
2141 C
2142 IF (ISAME .GT. 0) THEN
2143 IF (IDUP(ISAME).NE.0 .AND. IDUP(II).NE.0) THEN
2144 IDUP(ISAME) = ABS(IDUP(ISAME))
2145 IDUP(II) = ABS(IDUP(II))
2146 ELSE
2147 N1 = 0
2148 N2 = 0
2149 IF (NTHB .GT. 1) THEN
2150 DO 150 N = 1, NTHB
2151 IF (ITHB(N) .EQ. ISAME) N1 = 1
2152 IF (ITHB(N) .EQ. II) N2 = 1
2153 150 CONTINUE
2154 ENDIF
2155 IF (N1 .EQ. N2) THEN
2156 KERR = .TRUE.
2157 WRITE (LOUT, 1050) ISAME
2158 ENDIF
2159 ENDIF
2160 ENDIF
2161 C
2162 IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II .AND. IFOP(NFAL).LT.0) THEN
2163 KERR = .TRUE.
2164 WRITE (LOUT, 1020)
2165 ENDIF
2166 C
2167 LREV = (NREV.GT.0 .AND. IREV(NREV).EQ.II)
2168 LLAN = (NLAN.GT.0 .AND. ILAN(NLAN).EQ.II)
2169 LRLT = (NRLT.GT.0 .AND. IRLT(NRLT).EQ.II)
2170 IF (LREV .AND. LLAN .AND. (.NOT.LRLT)) THEN
2171 KERR = .TRUE.
2172 WRITE (LOUT, 1030)
2173 ENDIF
2174 IF (LRLT .AND. (.NOT.LLAN)) THEN
2175 KERR = .TRUE.
2176 WRITE (LOUT, 1040)
2177 ENDIF
2178 IF (LRLT .AND. (.NOT.LREV)) THEN
2179 KERR = .TRUE.
2180 WRITE (LOUT, 1045)
2181 ENDIF
2182 C
2183 IF (EUNITS .EQ. 'KELV') THEN
2184 EFAC = 1.0
2185 ELSEIF (EUNITS .EQ. 'CAL/') THEN
2186 C convert E from cal/mole to Kelvin
2187 EFAC = 1.0 / 1.987
2188 ELSEIF (EUNITS .EQ. 'KCAL') THEN
2189 C convert E from kcal/mole to Kelvin
2190 EFAC = 1000.0 / 1.987
2191 ELSEIF (EUNITS .EQ. 'JOUL') THEN
2192 C convert E from Joules/mole to Kelvin
2193 EFAC = 1.0 / 8.314
2194 ELSEIF (EUNITS .EQ. 'KJOU') THEN
2195 C convert E from Kjoules/mole to Kelvin
2196 EFAC = 1000.0 / 8.314
2197 ENDIF
2198 PAR(3,II) = PAR(3,II) * EFAC
2199 C
2200 C IF (NREV.GT.0 .AND. IREV(NREV).EQ.II) RPAR(3,II)=RPAR(3,II)*EFAC
2201 C IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II) PFAL(3,II)=PFAL(3,II)*EFAC
2202 C
2203 IF (NREV.GT.0 .AND. IREV(NREV).EQ.II)
2204 1 RPAR(3,NREV) = RPAR(3,NREV) * EFAC
2205 IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II)
2206 1 PFAL(3,NFAL) = PFAL(3,NFAL) * EFAC
2207 C
2208 IF (AUNITS .EQ. 'MOLC') THEN
2209 NSTOR = 0
2210 NSTOP = 0
2211 DO 50 N = 1, MAXSP
2212 IF (NU(N,II) .LT. 0) THEN
2213 C sum of stoichiometric coefficients of reactants
2214 NSTOR = NSTOR + ABS(NU(N,II))
2215 ELSEIF (NU(N,II) .GT. 0) THEN
2216 C sum of stoichiometric coefficients of products
2217 NSTOP = NSTOP + NU(N,II)
2218 ENDIF
2219 50 CONTINUE
2220 C
2221 AVAG = 6.023E23
2222 C
2223 IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.II) THEN
2224 C
2225 C fall-off reaction, "(+M)" or "(+species name)" does not
2226 C count except in "LOW" A-factor;
2227 C reverse-rate declarations are not allowed
2228 C
2229 IF (NSTOR.GT.0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
2230 NSTOR = NSTOR + 1
2231 IF (NSTOR.GT.0) PFAL(1,NFAL) = PFAL(1,NFAL)*AVAG**(NSTOR-1)
2232 C
2233 ELSEIF (NTHB.GT.0 .AND. ITHB(NTHB).EQ.II) THEN
2234 C
2235 C third body reaction, "+M" counts as species in
2236 C forward and reverse A-factor conversion
2237 C
2238 NSTOR = NSTOR + 1
2239 NSTOP = NSTOP + 1
2240 IF (NSTOR.GT.0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
2241 IF (NREV.GT.0 .AND. IREV(NREV).EQ.II .AND. NSTOP.GT.0)
2242 1 RPAR(1,NREV) = RPAR(1,NREV) * AVAG**(NSTOP-1)
2243 C
2244 ELSE
2245 C
2246 C not third-body or fall-off reaction, but may have
2247 C reverse rates.
2248 C
2249 IF (NSTOR .GT. 0) PAR(1,II) = PAR(1,II) * AVAG**(NSTOR-1)
2250 IF (NREV.GT.0 .AND. IREV(NREV).EQ.II .AND. NSTOP.GT.0)
2251 1 RPAR(1,NREV) = RPAR(1,NREV) * AVAG**(NSTOP-1)
2252 ENDIF
2253 ENDIF
2254 C
2255 1020 FORMAT (6X,'Error...no LOW parameters given for fall-off...')
2256 1030 FORMAT (6X,'Error...reverse T-L required...')
2257 1040 FORMAT (6X,'Error...forward T-L required...')
2258 1045 FORMAT (6X,'Error...REV parameters must be given with RTL...')
2259 1050 FORMAT (6X,'Error...undeclared duplicate to reaction number ',I3)
2260 1060 FORMAT (6X,'Error...reaction does not balance...')
2261 RETURN
2262 END
2263 C----------------------------------------------------------------------C
2264 SUBROUTINE CKBAL (MXSPEC, KSPEC, KCOEF, MDIM, MM, KCHRG, KNCF,
2265 1 IERR)
2266 C
2267 C Checks elemental balance of reactants vs. products.
2268 C Checks charge balance of reaction.
2269 C
2270 C Input: MXSPEC - number of species allowed in a reaction
2271 C KSPEC(N),N=1,MXSPEC- array of species numbers in reaction
2272 C KCOEF(N) - stoichiometric coefficients of the species
2273 C MDIM - maximum number of elements allowed
2274 C MM - actual integer number of elements
2275 C KCHRG(K) - ionic charge Kth species
2276 C KNCF(M,K)- integer elemental composition of Kth species
2277 C Output: KERR - logical, =.TRUE. if reaction does not balance
2278 C F. Rupley, Div. 8245, 5/13/86
2279 C----------------------------------------------------------------------C
2280 C*****precision > double
2281 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2282 C*****END precision > double
2283 C*****precision > single
2284 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2285 C*****END precision > single
2286 C
2287 DIMENSION KSPEC(*), KCOEF(*), KNCF(MDIM,*), KCHRG(*)
2288 LOGICAL IERR
2289 C
2290 IERR = .FALSE.
2291 C
2292 C charge balance
2293 C
2294 KBAL = 0
2295 DO 50 N = 1, MXSPEC
2296 IF (KSPEC(N) .NE. 0)
2297 1 KBAL = KBAL + KCOEF(N)*KCHRG(KSPEC(N))
2298 50 CONTINUE
2299 IF (KBAL .NE. 0) IERR = .TRUE.
2300 C
2301 C element balance
2302 C
2303 DO 100 M = 1, MM
2304 MBAL = 0
2305 DO 80 N = 1, MXSPEC
2306 IF (KSPEC(N) .NE. 0)
2307 1 MBAL = MBAL + KCOEF(N)*KNCF(M,KSPEC(N))
2308 80 CONTINUE
2309 IF (MBAL .NE. 0) IERR = .TRUE.
2310 100 CONTINUE
2311 RETURN
2312 END
2313 C----------------------------------------------------------------------C
2314 SUBROUTINE CKRBAL (MXSPEC, KSPEC, RCOEF, MDIM, MM, KCHRG, KNCF,
2315 1 CKMIN, IERR)
2316 C
2317 C Checks elemental balance of reactants vs. products.
2318 C Checks charge balance of reaction.
2319 C
2320 C Input: MXSPEC - number of species allowed in a reaction
2321 C KSPEC(N),N=1,MXSPEC- array of species numbers in reaction
2322 C RCOEF(N) - stoichiometric coefficients of the species
2323 C MDIM - maximum number of elements allowed
2324 C MM - actual integer number of elements
2325 C KCHRG(K) - ionic charge Kth species
2326 C KNCF(M,K)- integer elemental composition of Kth species
2327 C Output: KERR - logical, =.TRUE. if reaction does not balance
2328 C F. Rupley, Div. 8245, 5/13/86
2329 C----------------------------------------------------------------------C
2330 C*****precision > double
2331 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2332 C*****END precision > double
2333 C*****precision > single
2334 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2335 C*****END precision > single
2336 C
2337 DIMENSION KSPEC(*), RCOEF(*), KNCF(MDIM,*), KCHRG(*)
2338 LOGICAL IERR
2339 C
2340 IERR = .FALSE.
2341 C
2342 C charge balance
2343 C
2344 SBAL = 0
2345 DO 50 N = 1, MXSPEC
2346 IF (KSPEC(N) .NE. 0)
2347 1 SBAL = SBAL + RCOEF(N)*KCHRG(KSPEC(N))
2348 50 CONTINUE
2349 IF (ABS(SBAL) .GT. CKMIN) IERR = .TRUE.
2350 C
2351 C element balance
2352 C
2353 DO 100 M = 1, MM
2354 SMBAL = 0
2355 DO 80 N = 1, MXSPEC
2356 IF (KSPEC(N) .NE. 0)
2357 1 SMBAL = SMBAL + RCOEF(N)*KNCF(M,KSPEC(N))
2358 80 CONTINUE
2359 IF (ABS(SMBAL) .GT. CKMIN) IERR = .TRUE.
2360 100 CONTINUE
2361 RETURN
2362 END
2363 C----------------------------------------------------------------------C
2364 SUBROUTINE CKDUP (I, MAXSP, NS, NR, NU, NUNK, NFAL, IFAL, KFAL,
2365 1 ISAME)
2366 C
2367 C Checks reaction I against the (I-1) reactions for duplication
2368 C----------------------------------------------------------------------C
2369 C*****precision > double
2370 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2371 C*****END precision > double
2372 C*****precision > single
2373 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2374 C*****END precision > single
2375 C
2376 DIMENSION NS(*), NR(*), NU(MAXSP,*), NUNK(MAXSP,*), IFAL(*),
2377 1 KFAL(*)
2378 C
2379 ISAME = 0
2380 NRI = NR(I)
2381 NPI = ABS(NS(I)) - NR(I)
2382 C
2383 DO 500 J = 1, I-1
2384 C
2385 NRJ = NR(J)
2386 NPJ = ABS(NS(J)) - NR(J)
2387 C
2388 IF (NRJ.EQ.NRI .AND. NPJ.EQ.NPI) THEN
2389 C
2390 NSAME = 0
2391 DO 20 N = 1, MAXSP
2392 KI = NUNK(N,I)
2393 NI = NU(N,I)
2394 C
2395 DO 15 L = 1, MAXSP
2396 KJ = NUNK(L,J)
2397 NJ = NU(L,J)
2398 IF (NJ.NE.0 .AND. KJ.EQ.KI .AND. NJ.EQ.NI)
2399 1 NSAME = NSAME + 1
2400 15 CONTINUE
2401 20 CONTINUE
2402 C
2403 IF (NSAME .EQ. ABS(NS(J))) THEN
2404 C
2405 C same products, reactants, coefficients, check fall-off
2406 C third body
2407 C
2408 IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.I) THEN
2409 DO 22 N = 1, NFAL-1
2410 IF (J.EQ.IFAL(N) .AND. KFAL(N).EQ.KFAL(NFAL)) THEN
2411 ISAME = J
2412 RETURN
2413 ENDIF
2414 22 CONTINUE
2415 RETURN
2416 ENDIF
2417 C
2418 ISAME = J
2419 RETURN
2420 ENDIF
2421 ENDIF
2422 C
2423 IF (NPI.EQ.NRJ .AND. NPJ.EQ.NRI) THEN
2424 C
2425 NSAME = 0
2426 DO 30 N = 1, MAXSP
2427 KI = NUNK(N,I)
2428 NI = NU(N,I)
2429 C
2430 DO 25 L = 1, MAXSP
2431 KJ = NUNK(L,J)
2432 NJ = NU(L,J)
2433 IF (NJ.NE.0 .AND. KJ.EQ.KI .AND. -NJ.EQ.NI)
2434 1 NSAME = NSAME + 1
2435 25 CONTINUE
2436 30 CONTINUE
2437 C
2438 IF (NSAME.EQ.ABS(NS(J)) .AND.
2439 1 (NS(J).GT.0 .OR. NS(I).GT.0)) THEN
2440 C
2441 C same products as J reactants, and vice-versa
2442 C
2443 IF (NFAL.GT.0 .AND. IFAL(NFAL).EQ.I) THEN
2444 DO 32 N = 1, NFAL-1
2445 IF (J.EQ.IFAL(N) .AND. KFAL(N).EQ.KFAL(NFAL)) THEN
2446 ISAME = J
2447 RETURN
2448 ENDIF
2449 32 CONTINUE
2450 RETURN
2451 ENDIF
2452 C
2453 ISAME = J
2454 RETURN
2455 ENDIF
2456 ENDIF
2457 C
2458 500 CONTINUE
2459 RETURN
2460 END
2461 C----------------------------------------------------------------------C
2462 SUBROUTINE CKISUB (LINE, SUB, NSUB)
2463 C
2464 C Generates an array of CHAR*(*) substrings from a CHAR*(*) string,
2465 C using blanks or tabs as delimiters
2466 C
2467 C Input: LINE - a CHAR*(*) line
2468 C Output: SUB - a CHAR*(*) array of substrings
2469 C NSUB - number of substrings found
2470 C A '!' will comment out a line, or remainder of the line.
2471 C F. Rupley, Div. 8245, 5/15/86
2472 C----------------------------------------------------------------------C
2473 C*****precision > double
2474 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2475 C*****END precision > double
2476 C*****precision > single
2477 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2478 C*****END precision > single
2479 C
2480 CHARACTER*(*) SUB(*), LINE
2481 NSUB = 0
2482 C
2483 DO 5 N = 1, LEN(LINE)
2484 IF (ICHAR(LINE(N:N)) .EQ. 9) LINE(N:N) = ' '
2485 5 CONTINUE
2486 C
2487 IF (IPPLEN(LINE) .LE. 0) RETURN
2488 C
2489 ILEN = ILASCH(LINE)
2490 C
2491 NSTART = IFIRCH(LINE)
2492 10 CONTINUE
2493 ISTART = NSTART
2494 NSUB = NSUB + 1
2495 SUB(NSUB) = ' '
2496 C
2497 DO 100 I = ISTART, ILEN
2498 ILAST = INDEX(LINE(ISTART:),' ') - 1
2499 IF (ILAST .GT. 0) THEN
2500 ILAST = ISTART + ILAST - 1
2501 ELSE
2502 ILAST = ILEN
2503 ENDIF
2504 SUB(NSUB) = LINE(ISTART:ILAST)
2505 IF (ILAST .EQ. ILEN) RETURN
2506 C
2507 NSTART = ILAST + IFIRCH(LINE(ILAST+1:))
2508 C
2509 C Does SUB have any slashes?
2510 C
2511 I1 = INDEX(SUB(NSUB),'/')
2512 IF (I1 .LE. 0) THEN
2513 IF (LINE(NSTART:NSTART) .NE. '/') GO TO 10
2514 NEND = NSTART + INDEX(LINE(NSTART+1:),'/')
2515 IND = INDEX(SUB(NSUB),' ')
2516 SUB(NSUB)(IND:) = LINE(NSTART:NEND)
2517 IF (NEND .EQ. ILEN) RETURN
2518 NSTART = NEND + IFIRCH(LINE(NEND+1:))
2519 GO TO 10
2520 ENDIF
2521 C
2522 C Does SUB have 2 slashes?
2523 C
2524 I2 = INDEX(SUB(NSUB)(I1+1:),'/')
2525 IF (I2 .GT. 0) GO TO 10
2526 C
2527 NEND = NSTART + INDEX(LINE(NSTART+1:),'/')
2528 IND = INDEX(SUB(NSUB),' ') + 1
2529 SUB(NSUB)(IND:) = LINE(NSTART:NEND)
2530 IF (NEND .EQ. ILEN) RETURN
2531 NSTART = NEND + IFIRCH(LINE(NEND+1:))
2532 C GO TO 10
2533 100 CONTINUE
2534 RETURN
2535 END
2536 C----------------------------------------------------------------------C
2537 SUBROUTINE IPNPAR (LINE, NPAR, IPAR, ISTART)
2538 C
2539 C Returns CHAR*(*) IPAR substring of CHAR*(*) string LINE which
2540 C contains NPAR real parameters
2541 C
2542 C Input: LINE - a CHAR*(*) line
2543 C NPAR - number of parameters expected
2544 C Output: IPAR - the substring of parameters only
2545 C ISTART - the starting location of IPAR substring
2546 C A '!' will comment out a line, or remainder of the line.
2547 C F. Rupley, Div. 8245, 5/14/86
2548 C----------------------------------------------------------------------C
2549 C*****precision > double
2550 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2551 C*****END precision > double
2552 C*****precision > single
2553 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2554 C*****END precision > single
2555 C
2556 CHARACTER*(*) LINE,IPAR
2557 C
2558 C----------Find Comment String (! signifies comment)
2559 C
2560 ILEN = IPPLEN(LINE)
2561 ISTART = 0
2562 N = 0
2563 IF (ILEN.GT.0) THEN
2564 DO 40 I = ILEN, 1, -1
2565 ISTART = I
2566 IPAR = ' '
2567 IPAR = LINE(ISTART:ILEN)
2568 IF (LINE(I:I).NE.' ') THEN
2569 IF (I .EQ. 1) RETURN
2570 IF (LINE(I-1:I-1) .EQ. ' ') THEN
2571 N = N + 1
2572 IF (N .EQ. NPAR) RETURN
2573 ENDIF
2574 ENDIF
2575 40 CONTINUE
2576 ENDIF
2577 RETURN
2578 END
2579 C----------------------------------------------------------------------C
2580 SUBROUTINE IPPARI(STRING, ICARD, NEXPEC, IVAL, NFOUND, IERR, LOUT)
2581 C BEGIN PROLOGUE IPPARI
2582 C REFER TO IPGETI
2583 C DATE WRITTEN 850625 (YYMMDD)
2584 C REVISION DATE 851725 (YYMMDD)
2585 C CATEGORY NO. J3.,J4.,M2.
2586 C KEYWORDS PARSE
2587 C AUTHOR CLARK,G.L.,GROUP C-3 LOS ALAMOS NAT'L LAB
2588 C PURPOSE Parses integer variables from a character variable. Called
2589 C by IPGETI, the IOPAK routine used for interactive input.
2590 C DESCRIPTION
2591 C
2592 C-----------------------------------------------------------------------
2593 C IPPARI may be used for parsing an input record that contains integer
2594 C values, but was read into a character variable instead of directly
2595 C into integer variables.
2596 C The following benefits are gained by this approach:
2597 C - specification of only certain elements of the array is allowed,
2598 C thus letting the others retain default values
2599 C - variable numbers of values may be input in a record, up to a
2600 C specified maximum
2601 C - control remains with the calling program in case of an input
2602 C error
2603 C - diagnostics may be printed by IPPARI to indicate the nature
2604 C of input errors
2605 C
2606 C The contents of STRING on input indicate which elements of IVAL
2607 C are to be changed from their entry values, and values to which
2608 C they should be changed on exit. Commas and blanks serve as
2609 C delimiters, but multiple blanks are treated as a single delimeter.
2610 C Thus, an input record such as:
2611 C ' 1, 2,,40000 , ,60'
2612 C is interpreted as the following set of instructions by IPGETR:
2613 C
2614 C (1) set IVAL(1) = 1
2615 C (2) set IVAL(2) = 2
2616 C (3) leave IVAL(3) unchanged
2617 C (4) set IVAL(4) = 40000
2618 C (5) leave IVAL(5) unchanged
2619 C (6) set IVAL(6) = 60
2620 C
2621 C IPPARI will print diagnostics on the default output device, if
2622 C desired.
2623 C
2624 C IPPARI is part of IOPAK, and is written in ANSI FORTRAN 77
2625 C
2626 C Examples:
2627 C
2628 C Assume IVAL = (0, 0, 0) and NEXPEC = 3 on entry:
2629 C
2630 C input string IVAL on exit IERR NFOUND
2631 C ------------- ---------------------- ---- ------
2632 C ' 2 , 3 45 ' (2, 3, 45) 0 3
2633 C '2.15,,3' (2, 0, 3) 1 0
2634 C '3X, 25, 2' (0, 0, 0) 1 0
2635 C '10000' (10000, 0, 0) 2 1
2636 C
2637 C Assume IVAL = (0, 0, 0, 0) and NEXPEC = -4 on entry:
2638 C
2639 C input string IVAL on exit IERR NFOUND
2640 C ------------- ---------------------- ---- ------
2641 C '1, 2' (1, 2) 0 2
2642 C ',,37 400' (0, 0, 37, 400) 0 4
2643 C ' 1,,-3,,5' (1, 0, -3, 0) 3 4
2644 C
2645 C arguments: (I=input,O=output)
2646 C -----------------------------
2647 C STRING (I) - the character string to be parsed.
2648 C
2649 C ICARD (I) - data statement number, and error processing flag
2650 C < 0 : no error messages printed
2651 C = 0 : print error messages, but not ICARD
2652 C > 0 : print error messages, and ICARD
2653 C
2654 C NEXPEC (I) - number of real variables expected to be input. If
2655 C < 0, the number is unknown, and any number of values
2656 C between 0 and abs(nexpec) may be input. (see NFOUND)
2657 C
2658 C PROMPT (I) - prompting string, character type. A question
2659 C mark will be added to form the prompt at the screen.
2660 C
2661 C IVAL (I,O) - the integer value or values to be modified. On entry,
2662 C the values are printed as defaults. The formal parameter
2663 C corresponding to IVAL must be dimensioned at least NEXPEC
2664 C in the calling program if NEXPEC > 1.
2665 C
2666 C NFOUND (O) - the number of real values represented in STRING,
2667 C only in the case that there were as many or less than
2668 C NEXPEC.
2669 C
2670 C IERR (O) - error flag:
2671 C = 0 if no errors found
2672 C = 1 syntax errors or illegal values found
2673 C = 2 for too few values found (NFOUND < NEXPEC)
2674 C = 3 for too many values found (NFOUND > NEXPEC)
2675 C-----------------------------------------------------------------------
2676 C
2677 C REFERENCES (NONE)
2678 C ROUTINES CALLED IFIRCH,ILASCH
2679 C END PROLOGUE IPPARI
2680 C*****precision > double
2681 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2682 C*****END precision > double
2683 C
2684 C*****precision > single
2685 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2686 C*****END precision > single
2687 C
2688 C
2689 CHARACTER STRING*(*), ITEMP*80
2690 DIMENSION IVAL(*)
2691 CHARACTER *8 FMT(14)
2692 LOGICAL OKINCR
2693 C
2694 C FIRST EXECUTABLE STATEMENT IPPARI
2695 IERR = 0
2696 NFOUND = 0
2697 NEXP = IABS(NEXPEC)
2698 IE = ILASCH(STRING)
2699 IF (IE .EQ. 0) GO TO 500
2700 NC = 1
2701 C
2702 C--- OKINCR is a flag that indicates it's OK to increment
2703 C--- NFOUND, the index of the array into which the value
2704 C--- should be read. It is set false when a space follows
2705 C--- an integer value substring, to keep incrementing from
2706 C--- occurring if a comma should be encountered before the
2707 C--- next value.
2708 C
2709 OKINCR = .TRUE.
2710 C
2711 C--- begin overall loop on characters in string
2712 C
2713 100 CONTINUE
2714 C
2715 IF (STRING(NC:NC) .EQ. ',') THEN
2716 IF (OKINCR .OR. NC .EQ. IE) THEN
2717 NFOUND = NFOUND + 1
2718 ELSE
2719 OKINCR = .TRUE.
2720 ENDIF
2721 C
2722 GO TO 450
2723 ENDIF
2724 IF (STRING(NC:NC) .EQ. ' ') GO TO 450
2725 C
2726 C--- first good character (non-delimeter) found - now find
2727 C--- last good character
2728 C
2729 IBS = NC
2730 160 CONTINUE
2731 NC = NC + 1
2732 IF (NC .GT. IE) GO TO 180
2733 IF (STRING(NC:NC) .EQ. ' ')THEN
2734 OKINCR = .FALSE.
2735 ELSEIF (STRING(NC:NC) .EQ. ',')THEN
2736 OKINCR = .TRUE.
2737 ELSE
2738 GO TO 160
2739 ENDIF
2740 C
2741 C--- end of substring found - read value into integer array
2742 C
2743 180 CONTINUE
2744 NFOUND = NFOUND + 1
2745 IF (NFOUND .GT. NEXP) THEN
2746 IERR = 3
2747 GO TO 500
2748 ENDIF
2749 C
2750 IES = NC - 1
2751 NCH = IES - IBS + 1
2752 DATA FMT/' (I1)', ' (I2)', ' (I3)', ' (I4)', ' (I5)',
2753 1 ' (I6)', ' (I7)', ' (I8)', ' (I9)', '(I10)',
2754 2 '(I11)', '(I12)', '(I13)', '(I14)'/
2755 ITEMP = ' '
2756 ITEMP = STRING(IBS:IES)
2757 READ (ITEMP(1:NCH), FMT(NCH), ERR = 400) IVAL(NFOUND)
2758 GO TO 450
2759 400 CONTINUE
2760 IERR = 1
2761 GO TO 510
2762 450 CONTINUE
2763 NC = NC + 1
2764 IF (NC .LE. IE) GO TO 100
2765 C
2766 500 CONTINUE
2767 IF (NEXPEC .GT. 0 .AND. NFOUND .LT. NEXP) IERR = 2
2768 510 CONTINUE
2769 C
2770 IF (IERR .EQ. 0 .OR. ICARD .LT. 0)RETURN
2771 IF (ICARD .NE. 0) WRITE (LOUT, '(A,I3)')
2772 1 '!! ERROR IN DATA STATEMENT NUMBER', ICARD
2773 IF (IERR .EQ. 1)
2774 1 WRITE (LOUT, '(A)')'SYNTAX ERROR, OR ILLEGAL VALUE'
2775 IF (IERR .EQ. 2) WRITE (LOUT, '(A,I2, A, I2)')
2776 1 ' TOO FEW DATA ITEMS. NUMBER FOUND = ' , NFOUND,
2777 2 ' NUMBER EXPECTED = ', NEXPEC
2778 IF (IERR .EQ. 3) WRITE (LOUT, '(A,I2)')
2779 1 ' TOO MANY DATA ITEMS. NUMBER EXPECTED = ', NEXPEC
2780 END
2781 C
2782 SUBROUTINE IPPARR(STRING, ICARD, NEXPEC, RVAL, NFOUND, IERR, LOUT)
2783 C BEGIN PROLOGUE IPPARR
2784 C REFER TO IPGETR
2785 C DATE WRITTEN 850625 (YYMMDD)
2786 C REVISION DATE 851625 (YYMMDD)
2787 C CATEGORY NO. J3.,J4.,M2.
2788 C KEYWORDS PARSE
2789 C AUTHOR CLARK,G.L.,GROUP C-3 LOS ALAMOS NAT'L LAB
2790 C PURPOSE Parses real variables from a character variable. Called
2791 C by IPGETR, the IOPAK routine used for interactive input.
2792 C DESCRIPTION
2793 C
2794 C-----------------------------------------------------------------------
2795 C IPPARR may be used for parsing an input record that contains real
2796 C values, but was read into a character variable instead of directly
2797 C into real variables.
2798 C The following benefits are gained by this approach:
2799 C - specification of only certain elements of the array is allowed,
2800 C thus letting the others retain default values
2801 C - variable numbers of values may be input in a record, up to a
2802 C specified maximum
2803 C - control remains with the calling program in case of an input
2804 C error
2805 C - diagnostics may be printed by IPPARR to indicate the nature
2806 C of input errors
2807 C
2808 C The contents of STRING on input indicate which elements of RVAL
2809 C are to be changed from their entry values, and values to which
2810 C they should be changed on exit. Commas and blanks serve as
2811 C delimiters, but multiple blanks are treated as a single delimeter.
2812 C Thus, an input record such as:
2813 C ' 1., 2,,4.e-5 , ,6.e-6'
2814 C is interpreted as the following set of instructions by IPGETR:
2815 C
2816 C (1) set RVAL(1) = 1.0
2817 C (2) set RVAL(2) = 2.0
2818 C (3) leave RVAL(3) unchanged
2819 C (4) set RVAL(4) = 4.0E-05
2820 C (5) leave RVAL(5) unchanged
2821 C (6) set RVAL(6) = 6.0E-06
2822 C
2823 C IPPARR will print diagnostics on the default output device, if
2824 C desired.
2825 C
2826 C IPPARR is part of IOPAK, and is written in ANSI FORTRAN 77
2827 C
2828 C Examples:
2829 C
2830 C Assume RVAL = (0., 0., 0.) and NEXPEC = 3 on entry:
2831 C
2832 C input string RVAL on exit IERR NFOUND
2833 C ------------- ---------------------- ---- ------
2834 C ' 2.34e-3, 3 45.1' (2.34E-03, 3.0, 45.1) 0 3
2835 C '2,,3.-5' (2.0, 0.0, 3.0E-05) 0 3
2836 C ',1.4,0.028E4' (0.0, 1.4, 280.0) 0 3
2837 C '1.0, 2.a4, 3.0' (1.0, 0.0, 0.0) 1 1
2838 C '1.0' (1.0, 0.0, 0.0) 2 1
2839 C
2840 C Assume RVAL = (0.,0.,0.,0.) and NEXPEC = -4 on entry:
2841 C
2842 C input string RVAL on exit IERR NFOUND
2843 C ------------- ---------------------- ---- ------
2844 C '1.,2.' (1.0, 2.0) 0 2
2845 C ',,3 4.0' (0.0, 0.0, 3.0, 4.0) 0 4
2846 C '1,,3,,5.0' (0.0, 0.0, 3.0, 0.0) 3 4
2847 C
2848 C arguments: (I=input,O=output)
2849 C -----------------------------
2850 C STRING (I) - the character string to be parsed.
2851 C
2852 C ICARD (I) - data statement number, and error processing flag
2853 C < 0 : no error messages printed
2854 C = 0 : print error messages, but not ICARD
2855 C > 0 : print error messages, and ICARD
2856 C
2857 C NEXPEC (I) - number of real variables expected to be input. If
2858 C < 0, the number is unknown, and any number of values
2859 C between 0 and abs(nexpec) may be input. (see NFOUND)
2860 C
2861 C PROMPT (I) - prompting string, character type. A question
2862 C mark will be added to form the prompt at the screen.
2863 C
2864 C RVAL (I,O) - the real value or values to be modified. On entry,
2865 C the values are printed as defaults. The formal parameter
2866 C corresponding to RVAL must be dimensioned at least NEXPEC
2867 C in the calling program if NEXPEC > 1.
2868 C
2869 C NFOUND (O) - the number of real values represented in STRING,
2870 C only in the case that there were as many or less than
2871 C NEXPEC.
2872 C
2873 C IERR (O) - error flag:
2874 C = 0 if no errors found
2875 C = 1 syntax errors or illegal values found
2876 C = 2 for too few values found (NFOUND < NEXPEC)
2877 C = 3 for too many values found (NFOUND > NEXPEC)
2878 C-----------------------------------------------------------------------
2879 C
2880 C REFERENCES (NONE)
2881 C ROUTINES CALLED IFIRCH,ILASCH
2882 C END PROLOGUE IPPARR
2883 C*****precision > double
2884 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
2885 C*****END precision > double
2886 C
2887 C*****precision > single
2888 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
2889 C*****END precision > single
2890 C
2891 CHARACTER STRING*(*), ITEMP*80
2892 DIMENSION RVAL(*)
2893 CHARACTER *8 FMT(22)
2894 LOGICAL OKINCR
2895 C
2896 C FIRST EXECUTABLE STATEMENT IPPARR
2897 IERR = 0
2898 NFOUND = 0
2899 NEXP = IABS(NEXPEC)
2900 IE = ILASCH(STRING)
2901 IF (IE .EQ. 0) GO TO 500
2902 NC = 1
2903 C
2904 C--- OKINCR is a flag that indicates it's OK to increment
2905 C--- NFOUND, the index of the array into which the value
2906 C--- should be read. It is set negative when a space follows
2907 C--- a real value substring, to keep incrementing from
2908 C--- occurring if a comma should be encountered before the
2909 C--- next value.
2910 C
2911 OKINCR = .TRUE.
2912 C
2913 C--- begin overall loop on characters in string
2914 C
2915 100 CONTINUE
2916 C
2917 IF (STRING(NC:NC) .EQ. ',') THEN
2918 IF (OKINCR) THEN
2919 NFOUND = NFOUND + 1
2920 ELSE
2921 OKINCR = .TRUE.
2922 ENDIF
2923 C
2924 GO TO 450
2925 ENDIF
2926 IF (STRING(NC:NC) .EQ. ' ') GO TO 450
2927 C
2928 C--- first good character (non-delimeter) found - now find
2929 C--- last good character
2930 C
2931 IBS = NC
2932 160 CONTINUE
2933 NC = NC + 1
2934 IF (NC .GT. IE) GO TO 180
2935 IF (STRING(NC:NC) .EQ. ' ')THEN
2936 OKINCR = .FALSE.
2937 ELSEIF (STRING(NC:NC) .EQ. ',')THEN
2938 OKINCR = .TRUE.
2939 ELSE
2940 GO TO 160
2941 ENDIF
2942 C
2943 C--- end of substring found - read value into real array
2944 C
2945 180 CONTINUE
2946 NFOUND = NFOUND + 1
2947 IF (NFOUND .GT. NEXP) THEN
2948 IERR = 3
2949 GO TO 500
2950 ENDIF
2951 C
2952 DATA FMT/ ' (E1.0)', ' (E2.0)', ' (E3.0)', ' (E4.0)',
2953 1 ' (E5.0)', ' (E6.0)', ' (E7.0)', ' (E8.0)', ' (E9.0)',
2954 2 '(E10.0)', '(E11.0)', '(E12.0)', '(E13.0)', '(E14.0)',
2955 3 '(E15.0)', '(E16.0)', '(E17.0)', '(E18.0)', '(E19.0)',
2956 4 '(E20.0)', '(E21.0)', '(E22.0)'/
2957 IES = NC - 1
2958 NCH = IES - IBS + 1
2959 ITEMP = ' '
2960 ITEMP = STRING(IBS:IES)
2961 READ (ITEMP(1:NCH), FMT(NCH), ERR = 400) RVAL(NFOUND)
2962 GO TO 450
2963 400 CONTINUE
2964 WRITE (LOUT, 555) STRING(IBS:IES)
2965 555 FORMAT (A)
2966 IERR = 1
2967 GO TO 510
2968 450 CONTINUE
2969 NC = NC + 1
2970 IF (NC .LE. IE) GO TO 100
2971 C
2972 500 CONTINUE
2973 IF (NEXPEC .GT. 0 .AND. NFOUND .LT. NEXP) IERR = 2
2974 510 CONTINUE
2975 C
2976 IF (IERR .EQ. 0 .OR. ICARD .LT. 0) RETURN
2977 IF (ICARD .NE. 0) WRITE (LOUT, '(A,I3)')
2978 1 '!! ERROR IN DATA STATEMENT NUMBER', ICARD
2979 IF (IERR .EQ. 1)
2980 1 WRITE (LOUT, '(A)')'SYNTAX ERROR, OR ILLEGAL VALUE'
2981 IF (IERR .EQ. 2) WRITE (LOUT, '(A,I2, A, I2)')
2982 1 ' TOO FEW DATA ITEMS. NUMBER FOUND = ' , NFOUND,
2983 2 ' NUMBER EXPECTED = ', NEXPEC
2984 IF (IERR .EQ. 3) WRITE (LOUT, '(A,I2)')
2985 1 ' TOO MANY DATA ITEMS. NUMBER EXPECTED = ', NEXPEC
2986 END
2987 C
2988 FUNCTION IFIRCH(STRING)
2989 C BEGIN PROLOGUE IFIRCH
2990 C DATE WRITTEN 850626
2991 C REVISION DATE 850626
2992 C CATEGORY NO. M4.
2993 C KEYWORDS CHARACTER STRINGS,SIGNIFICANT CHARACTERS
2994 C AUTHOR CLARK,G.L.,GROUP C-3 LOS ALAMOS NAT'L LAB
2995 C PURPOSE Determines first significant (non-blank) character
2996 C in character variable
2997 C DESCRIPTION
2998 C
2999 C-----------------------------------------------------------------------
3000 C IFIRCH locates the first non-blank character in a string of
3001 C arbitrary length. If no characters are found, IFIRCH is set = 0.
3002 C When used with the companion routine ILASCH, the length of a string
3003 C can be determined, and/or a concatenated substring containing the
3004 C significant characters produced.
3005 C-----------------------------------------------------------------------
3006 C
3007 C REFERENCES (NONE)
3008 C ROUTINES CALLED (NONE)
3009 C END PROLOGUE IFIRCH
3010 C*****precision > double
3011 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
3012 C*****END precision > double
3013 C
3014 C*****precision > single
3015 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
3016 C*****END precision > single
3017 C
3018 CHARACTER* (*)STRING
3019 C
3020 C FIRST EXECUTABLE STATEMENT IFIRCH
3021 NLOOP = LEN(STRING)
3022 C
3023 IF (NLOOP .EQ. 0) THEN
3024 IFIRCH = 0
3025 RETURN
3026 ENDIF
3027 C
3028 DO 100 I = 1, NLOOP
3029 IF (STRING(I:I) .NE. ' ') GO TO 120
3030 100 CONTINUE
3031 C
3032 IFIRCH = 0
3033 RETURN
3034 120 CONTINUE
3035 IFIRCH = I
3036 END
3037 FUNCTION ILASCH(STRING)
3038 C BEGIN PROLOGUE ILASCH
3039 C DATE WRITTEN 850626
3040 C REVISION DATE 850626
3041 C CATEGORY NO. M4.
3042 C KEYWORDS CHARACTER STRINGS,SIGNIFICANT CHARACTERS
3043 C AUTHOR CLARK,G.L.,GROUP C-3 LOS ALAMOS NAT'L LAB
3044 C PURPOSE Determines last significant (non-blank) character
3045 C in character variable
3046 C DESCRIPTION
3047 C
3048 C-----------------------------------------------------------------------
3049 C IFIRCH locates the last non-blank character in a string of
3050 C arbitrary length. If no characters are found, ILASCH is set = 0.
3051 C When used with the companion routine IFIRCH, the length of a string
3052 C can be determined, and/or a concatenated substring containing the
3053 C significant characters produced.
3054 C Note that the FORTRAN intrinsic function LEN returns the length
3055 C of a character string as declared, rather than as filled. The
3056 C declared length includes leading and trailing blanks, and thus is
3057 C not useful in generating 'significant' substrings.
3058 C-----------------------------------------------------------------------
3059 C
3060 C REFERENCES (NONE)
3061 C ROUTINES CALLED (NONE)
3062 C END PROLOGUE IFIRCH
3063 C*****precision > double
3064 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
3065 C*****END precision > double
3066 C
3067 C*****precision > single
3068 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
3069 C*****END precision > single
3070 C
3071 CHARACTER*(*) STRING
3072 C
3073 C***FIRST EXECUTABLE STATEMENT ILASCH
3074 NLOOP = LEN(STRING)
3075 IF (NLOOP.EQ.0) THEN
3076 ILASCH = 0
3077 RETURN
3078 ENDIF
3079 C
3080 DO 100 I = NLOOP, 1, -1
3081 IF (STRING(I:I) .NE. ' ') GO TO 120
3082 100 CONTINUE
3083 C
3084 120 CONTINUE
3085 ILASCH = I
3086 END
3087 C----------------------------------------------------------------------C
3088 C
3089 SUBROUTINE CKCOMP (IST, IRAY, II, I)
3090 C
3091 C START PROLOGUE
3092 C
3093 C SUBROUTINE CKCOMP (IST, IRAY, II, I)*
3094 C Returns the index of an element of a reference character
3095 C string array which corresponds to a character string;
3096 C leading and trailing blanks are ignored.
3097 C
3098 C
3099 C INPUT
3100 C IST - A character string.
3101 C Data type - CHARACTER*(*)
3102 C IRAY - An array of character strings;
3103 C dimension IRAY(*) at least II
3104 C Data type - CHARACTER*(*)
3105 C II - The length of IRAY.
3106 C Data type - integer scalar.
3107 C
3108 C OUTPUT
3109 C I - The first integer location in IRAY in which IST
3110 C corresponds to IRAY(I); if IST is not also an
3111 C entry in IRAY, I=0.
3112 C
3113 C END PROLOGUE
3114 C
3115 C*****precision > double
3116 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
3117 C*****END precision > double
3118 C*****precision > single
3119 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
3120 C*****END precision > single
3121 C
3122 CHARACTER*(*) IST, IRAY(*)
3123 C
3124 I = 0
3125 DO 10 N = II, 1, -1
3126 IS1 = IFIRCH(IST)
3127 IS2 = ILASCH(IST)
3128 IR1 = IFIRCH(IRAY(N))
3129 IR2 = ILASCH(IRAY(N))
3130 IF ( IS2.GE.IS1 .AND. IS2.GT.0 .AND.
3131 1 IR2.GE.IR1 .AND. IR2.GT.0 .AND.
3132 2 IST(IS1:IS2).EQ.IRAY(N)(IR1:IR2) ) I=N
3133 10 CONTINUE
3134 RETURN
3135 END
3136 C
3137 C----------------------------------------------------------------------C
3138 SUBROUTINE CKUNIT (LINE, AUNITS, EUNITS, IUNITS)
3139 C
3140 C*****precision > double
3141 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
3142 C*****END precision > double
3143 C*****precision > single
3144 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
3145 C*****END precision > single
3146 CHARACTER*(*) LINE, IUNITS, AUNITS, EUNITS
3147 CHARACTER*4 UPCASE
3148 C
3149 AUNITS = ' '
3150 EUNITS = ' '
3151 IUNITS = ' '
3152 LCHAR = ILASCH(LINE)
3153 DO 85 N = 1, ILASCH(LINE)-3
3154 IND = ILASCH(IUNITS)
3155 IF (EUNITS .EQ. ' ') THEN
3156 IF (UPCASE(LINE(N:), 4) .EQ. 'CAL/') THEN
3157 EUNITS = 'CAL/'
3158 IF (IUNITS .EQ. ' ') THEN
3159 IUNITS = 'E units cal/mole'
3160 ELSE
3161 IUNITS(IND:) = ', E units cal/mole'
3162 ENDIF
3163 ELSEIF (UPCASE(LINE(N:), 4) .EQ. 'KCAL') THEN
3164 EUNITS = 'KCAL'
3165 IF (IUNITS .EQ. ' ') THEN
3166 IUNITS = 'E units Kcal/mole'
3167 ELSE
3168 IUNITS(IND:) = ', E units Kcal/mole'
3169 ENDIF
3170 ELSEIF (UPCASE(LINE(N:), 4) .EQ. 'JOUL') THEN
3171 EUNITS = 'JOUL'
3172 IF (IUNITS .EQ. ' ') THEN
3173 IUNITS = 'E units Joules/mole'
3174 ELSE
3175 IUNITS(IND:) = ', E units Joules/mole'
3176 ENDIF
3177 ELSEIF (UPCASE(LINE(N:), 4) .EQ. 'KJOU') THEN
3178 EUNITS = 'KJOU'
3179 IF (IUNITS .EQ. ' ') THEN
3180 IUNITS = 'E units Kjoule/mole'
3181 ELSE
3182 IUNITS(IND:) = ', E units Kjoule/mole'
3183 ENDIF
3184 ELSEIF (UPCASE(LINE(N:), 4) .EQ. 'KELV') THEN
3185 EUNITS = 'KELV'
3186 IF (IUNITS .EQ. ' ') THEN
3187 IUNITS = 'E units Kelvins'
3188 ELSE
3189 IUNITS(IND:) = ', E units Kelvins'
3190 ENDIF
3191 ENDIF
3192 ENDIF
3193 IF (AUNITS .EQ. ' ') THEN
3194 IF (UPCASE(LINE(N:), 4) .EQ. 'MOLE') THEN
3195 IF (N+4.LE.ILASCH(LINE) .AND.
3196 1 UPCASE(LINE(N+4:),1).EQ.'C') THEN
3197 C
3198 AUNITS = 'MOLC'
3199 IF (IUNITS .EQ. ' ') THEN
3200 IUNITS = 'A units molecules'
3201 ELSE
3202 IUNITS(IND:) = ', A units molecules'
3203 ENDIF
3204 ELSE
3205 AUNITS = 'MOLE'
3206 IF (IUNITS .EQ. ' ') THEN
3207 IUNITS = 'A units mole-cm-sec-K'
3208 ELSE
3209 IUNITS(IND:) = ', A units mole-cm-sec-K'
3210 ENDIF
3211 ENDIF
3212 ENDIF
3213 ENDIF
3214 85 CONTINUE
3215 C
3216 IF (AUNITS .EQ. ' ') THEN
3217 AUNITS = 'MOLE'
3218 IND = ILASCH(IUNITS) + 1
3219 IF (IND .GT. 1) THEN
3220 IUNITS(IND:) = ', A units mole-cm-sec-K'
3221 ELSE
3222 IUNITS(IND:) = ' A units mole-cm-sec-K'
3223 ENDIF
3224 ENDIF
3225 C
3226 IF (EUNITS .EQ. ' ') THEN
3227 EUNITS = 'CAL/'
3228 IND = ILASCH(IUNITS) + 1
3229 IF (IND .GT. 1) THEN
3230 IUNITS(IND:) = ', E units cal/mole'
3231 ELSE
3232 IUNITS(IND:) = ' E units cal/mole'
3233 ENDIF
3234 ENDIF
3235 C
3236 RETURN
3237 END
3238 C
3239 C----------------------------------------------------------------------C
3240 C
3241 INTEGER FUNCTION IPPLEN (LINE)
3242 C
3243 C BEGIN PROLOGUE
3244 C
3245 C FUNCTION IPPLEN (LINE)
3246 C Returns the effective length of a character string, i.e.,
3247 C the index of the last character before an exclamation mark (!)
3248 C indicating a comment.
3249 C
3250 C INPUT
3251 C LINE - A character string.
3252 C
3253 C OUTPUT
3254 C IPPLEN - The effective length of the character string.
3255 C
3256 C END PROLOGUE
3257 C
3258 C*****precision > double
3259 IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
3260 C*****END precision > double
3261 C*****precision > single
3262 C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
3263 C*****END precision > single
3264 C
3265 CHARACTER LINE*(*)
3266 C
3267 IN = IFIRCH(LINE)
3268 IF (IN.EQ.0 .OR. LINE(IN:IN).EQ.'!') THEN
3269 IPPLEN = 0
3270 ELSE
3271 IN = INDEX(LINE,'!')
3272 IF (IN .EQ. 0) THEN
3273 IPPLEN = ILASCH(LINE)
3274 ELSE
3275 IPPLEN = ILASCH(LINE(:IN-1))
3276 ENDIF
3277 ENDIF
3278 RETURN
3279 END
3280 C
3281 CHARACTER*(*) FUNCTION UPCASE(ISTR, ILEN)
3282 CHARACTER ISTR*(*), LCASE(26)*1, UCASE(26)*1
3283 DATA LCASE /'a','b','c','d','e','f','g','h','i','j','k','l','m',
3284 1 'n','o','p','q','r','s','t','u','v','w','x','y','z'/,
3285 2 UCASE /'A','B','C','D','E','F','G','H','I','J','K','L','M',
3286 3 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
3287 C
3288 UPCASE = ' '
3289 UPCASE = ISTR(:ILEN)
3290 JJ = MIN (LEN(UPCASE), LEN(ISTR), ILEN)
3291 DO 10 J = 1, JJ
3292 DO 10 N = 1,26
3293 IF (ISTR(J:J) .EQ. LCASE(N)) UPCASE(J:J) = UCASE(N)
3294 10 CONTINUE
3295 RETURN
3296 END
Just a mirror of the officiall OpenCFD 1.7-dev repository from github since I could not check it out using http.