1 C/////////////////////////////////////////////////////////////////// 66 C

2 C 67 C*****precision > single

3 C ONE DIMENSIONAL OPPOSED FLOW FLAME CODE, 68 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
4 C 69 C*****END precision > single
5 C WRITTEN BY: 70 C
6 C ROBERT J. KEE, ANDREW E. LUTZ 71 DIMENSION I(*), R(*)
7 C COMPUTATIONAL MECHANICS DIVISION 72 DIMENSION PMAC(7,4), NRAD(4), NNARROW(6)
8 C SANDIA NATIONAL LABORATORIES 73 CHARACTER C(*)*(*), LINE*80
9 C LIVERMORE, CA 94550 74 LOGICAL L(*),IERR
10 C TEL (510) 294-3272 75 CHARACTER *16 KSYM(200)
11 C FAX (510) 294-1459 76 C
12 C 77 COMMON /FLFLFL/ NCKW, NMCW, NYOX, NYFL, NWT, NFL, NPD, NOX,
13 C///////////////////////////////////////////////////////////////////// 78 1 NSCH, NX, NVIS, NCON, NTGV, NXGV, ND, NDKJ,
14 C 79 2 NTDR, NYV, NABV, NBLW, NBUF, NTWP, NS, NSN,
15 C VERSION 3.3 80 3 NFF, NFN, NDS, NSSV, NA,
16 C 1.1 ADD CORRECTION VELOCITY TO DIFFUSION IN -MDIFV- 81 4 ICKW, IMCW, ITPW, IKS, ICC, IIP, LAC, LMK,
17 C COMPUTE SPECIES EQN FOR LAST SPECIES 82 C ADDED FOR EQUIL...
18 C 1.2 VELOCITY DEPENDENT WINDWARD DIFFERENCING 83 5 IEQW, IATOM, NREAC, NDCS, NEQW
19 C 1.2A INITIAL G=DFDX=CONST 84 C
20 C 1.2B BRIEF PRINT (3 SPECIES REQUESTED) 85 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
21 C 1.2C LINEAR INITIAL PROFILE IN MASS FRACTIONS -START- 86 COMMON /RAD/ PMAC, NRAD ,NNARROW
22 C OPTION FOR COMPUTING STAGNATION PLANE LOCATION 87
23 C IF XCEN = 0. 88
24 C 1.2D COMPUTE EQUILIBRIUM AS GUESS FOR ENERGY SOLUTION 89 DATA PMAC/-14.3387, 50.1488, -51.2399, 25.1457, -6.6045, 0.89794,
25 C 1.2e solve for species with temp fixed at equil guess 90 1 -0.049815,6.5706, 5.0999, -9.5554, 5.0676, -1.3209,
26 C 1.2G Multiply reaction rates by factor (RATE). 91 2 0.17428, -0.0093028,-7.4695, 107.4515,-71.3651,4.0407,
27 C VERSION 2.0 92 3 8.5281, -2.596, 0.22943, 33.5054, 12.8293, -63.4786,
28 C Call list for TWOPNT requires additional input; optional 93 4 49.0054, -16.9312, 2.8096, -0.18177/
29 C use of new keywords reset default values: 94
30 C 'ISTP' n - sets NINIT initial time steps before newton 95 DATA LINE/'CO CH4 CO2 H2O'/
31 C (default is 0) 96 C
32 C 'IRET' n - set retirement age IRETIR of old time step 97 C WRITE VERSION NUMBER
33 C (default 50) 98 C
34 C 'NJAC' n - set retirement age NJAC of Jacobian during 99 WRITE (LOUT, 15)
35 C steady state newton (default 20) 100 15 FORMAT(
36 C 'TJAC' n - set retirement age ITJAC of Jacobian during 101 1/' OPPDIF: Opposed-flow diffusion-flame, pressure gradient',
37 C time stepping (default 20) 102 2/' Version 3.3, February 1995',
38 C 'DTMX' x - set maximum time step DTMAX (default 1.0E-4) 103 C*****precision > double
39 C VERSION 2.1 104 3/' DOUBLE PRECISION')
40 C 1. Initial profile is plateau with equil species. 105 C*****END precision > double
41 C 2. Use binary files instead of data from restart solution. 106 C*****precision > single
42 C VERSION 3.0 107 C 3/' SINGLE PRECISION')
43 C 1. Upgrade to EQUIL.30 108 C*****END precision > single
44 C 2. CALL CKRDEX instead of CKRAEX to perturb rates for 109 C
45 C sensitivities 110 C SET UP INTERNAL WORK POINTERS
46 C CHANGES FOR VERSION 3.1 (3/15/94 F. Rupley) 111 C
47 C 1. DOS/PC compatibility effort includes adding file names to 112 REWIND LSAVE
48 C OPEN statements, removing unused variables in CALL lists, 113 CALL POINT (LINKCK, LINKMC, NMAX, LOUT, LSAVE, KK, II, MM, NATJ,
49 C unusued but possibly initialized variables. 114 1 LENIWK, LENRWK, LENCWK, LENITW, LENTWP,
50 C CHANGES FOR VERSION 3.2 (1/19/95 F. Rupley) 115 2 LENICK, LENRCK, LENIEQ, LENREQ,
51 C 1. Add integer error flag to CKLEN, CKINIT, MCLEN, MCINIT 116 3 LTOT, ITOT, NTOT, ICTOT, I, R, C)
52 C call lists. 117 C
53 C CHANGES FOR VERSION 3.3 (2/27/95 F. Rupley) 118 C CHECK FOR ENOUGH SPACE
54 C 1. Change character index "(:" to "(1:" 119 C
55 C 120 WRITE (LOUT, 7000) LENLWK, LTOT, LENIWK, ITOT, LENRWK, NTOT,
56 C///////////////////////////////////////////////////////////////////// 121 1 LENCWK, ICTOT
57 C 122 7000 FORMAT (/,' WORKING SPACE REQUIREMENTS',
58 123 1 /,' PROVIDED REQUIRED ',
59 SUBROUTINE OPPDIF (NMAX, LIN, LOUT, LINKCK, LINKMC, LREST, LSAVE, 124 2 /,' LOGICAL ' , 2I15,
60 1 LRCRVR, LENLWK, L, LENIWK, I, LENRWK, R, 125 3 /,' INTEGER ' , 2I15,
61 2 LENCWK, C) 126 4 /,' REAL ' , 2I15,
62 C 127 5 /,' CHARACTER' , 2I15,/)
63 C*****precision > double 128 C
64 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 129 IF (LTOT.GT.LENLWK .OR. ITOT.GT.LENIWK .OR. NTOT.GT.LENRWK
65 C*****END precision > double 130 1 .OR. ICTOT.GT.LENCWK) THEN

131 WRITE (LOUT, *) ' FATAL ERROR, NOT ENOUGH WORK SPACE PROVIDED' 196 C
132 STOP 197 C
133 ENDIF 198 C SET THE POINTERS INTO THE SOLUTION VECTOR
134 C 199 C
135 C 200 NT = 1
136 CALL CKSYMS (C(ICC), LOUT, KSYM, IERR) 201 NG = 2
137 C 202 NF = 3
138 CALL CKCRAY (LINE, KK, KSYM, LOUT, 4, NRAD, NFD, IERR) 203 NH = 4
139 C 204 NYS = 4
140 C 205 NY = 5
141 C JUST FOR TEST 206 C
142 C 207 C CALL FOR CHEMKIN WORK ARRAY LENGTHS
143 WRITE (LOUT,'(1X,A)') 'RADIATING SPECIES:' 208 C
144 209 CALL CKLEN (LINKCK, LOUT, LENICK, LENRCK, LENCCK, IFLAG1)
145 WRITE (LOUT,'(8(1X,A))') 210 CALL MCLEN (LINKMC, LOUT, LENIMC, LENRMC, IFLAG2)
146 211 IF (IFLAG1.GT.0 .OR. IFLAG2.GT.0) STOP
147 1 ( KSYM( NRAD(K) ), K = 1, 4) 212 C
148 213 C real chemkin work space
149 214 NCKW = 1
150 C END TEST 215 C real transport work space
151 216 NMCW = NCKW + LENRCK
152 CALL FLDRIV (LENITW, LENTWP, LIN, LOUT, LREST, 217 NTOT = NMCW + LENRMC
153 1 LSAVE, LRCRVR, KK, II, MM, NATJ, NMAX, LENICK, LENRCK, 218 C
154 2 R(NCKW), R(NMCW), R(NYOX), R(NYFL), R(NWT), R(NFL), 219 C integer chemkin space
155 3 R(NPD), R(NOX), R(NSCH), R(NX), R(NVIS), R(NCON), 220 ICKW = 1
156 4 R(NTGV), R(NXGV), R(ND), R(NDKJ), R(NTDR), R(NYV), 221 C integer transport space
157 5 R(NABV), R(NBLW), R(NBUF), R(NTWP), R(NS), R(NSN), 222 IMCW = ICKW + LENICK
158 6 R(NFF), R(NFN), R(NDS), R(NSSV), R(NA), 223 ITOT = IMCW + LENIMC
159 7 I(ICKW), I(IMCW), I(ITPW), C(IKS), C(ICC), 224 C
160 8 I(IIP), L(LAC), L(LMK), 225 C characcter chemkin space
161 C EQUIL ARRAYS... 226 ICC = 1
162 9 I(IEQW), LENIEQ, R(NEQW), LENREQ, R(NREAC), 227 ICTOT = ICC + LENCCK
163 1 R(NDCS), C(IATOM) ) 228 C
164 229 IF (ITOT.LT.LENIWK .AND. NTOT.LT.LENRWK .AND. ICTOT.LT.LENCWK)
165 C 230 1 THEN
166 RETURN 231 CALL CKINIT (LENICK, LENRCK, LENCCK, LINKCK, LOUT, I, R, C,
167 END 232 1 IFLAG)
168 C 233 IF (IFLAG .GT. 0) STOP
169 C---------------------------------------------------------------------- 234 ILINK = 'CKLINK'
170 C 235 WRITE (LSAVE) ILINK
171 SUBROUTINE POINT (LINKCK, LINKMC, NMAX, LOUT, LSAVE, KK, II, MM, 236 CALL CKSAVE (LOUT, LSAVE, I, R, C)
172 1 NATJ, LENIWK, LENRWK, LENCWK, LENITW, LENTWP, 237 CALL CKINDX (I, R, MM, KK, II, NFIT)
173 2 LENICK, LENRCK, LENIEQ, LENREQ, 238 C
174 3 LTOT, ITOT, NTOT, ICTOT, I, R, C) 239 CALL MCINIT (LINKMC, LOUT, LENIMC, LENRMC, I(IMCW), R(NMCW),
175 C 240 1 IFLAG)
176 C*****precision > double 241 IF (IFLAG .GT. 0) STOP
177 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 242 ILINK = 'MCLINK'
178 C*****END precision > double 243 WRITE (LSAVE) ILINK
179 C 244 CALL MCSAVE (LOUT, LSAVE, I(IMCW), R(NMCW))
180 C*****precision > single 245 ENDIF
181 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 246 C
182 C*****END precision > single 247 C TWOPOINT WORK SPACE LENGTHS
183 C 248 C
184 DIMENSION I(*), R(*) 249 NATJ = KK+4
185 CHARACTER C(*)*(*), ILINK*16 250 LENITW = 3 * NMAX
186 C 251 LENTWP = (7*NATJ+2) * NMAX
187 COMMON /FLFLFL/ NCKW, NMCW, NYOX, NYFL, NWT, NFL, NPD, NOX, 252 C
188 1 NSCH, NX, NVIS, NCON, NTGV, NXGV, ND, NDKJ, 253 C STANJAN WORK SPACE LENGTHS
189 2 NTDR, NYV, NABV, NBLW, NBUF, NTWP, NS, NSN, 254 C
190 3 NFF, NFN, NDS, NSSV, NA, 255 NCON = 0
191 4 ICKW, IMCW, ITPW, IKS, ICC, IIP, LAC, LMK, 256 CALL EQLEN (MM, KK, NCON, LENIEQ, LENREQ)
192 C ADDED FOR EQUIL... 257 C
193 5 IEQW, IATOM, NREAC, NDCS, NEQW 258 C APPORTION THE FLOATING POINT SPACE
194 C 259 C
195 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY 260 NYOX = NTOT
261 NYFL = NYOX + KK 326 7 IEQWRK, LENIEQ, REQWRK, LENREQ, REAC,
262 NWT = NYFL + KK 327 8 DCS, ATOM )
263 NFL = NWT + KK 328 C
264 NPD = NFL + KK 329 C*****precision > double
265 NOX = NPD + KK 330 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
266 NSCH = NOX + KK 331 C*****END precision > double
267 NX = NSCH + KK*5 332 C
268 NVIS = NX + NMAX 333 C*****precision > single
269 NCON = NVIS + NMAX 334 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
270 NTGV = NCON + NMAX 335 C*****END precision > single
271 NXGV = NTGV + NMAX 336 C
272 ND = NXGV + NMAX 337 DIMENSION PMAC(7,4), NRAD(4), NNARROW(6)
273 NDKJ = ND + KK*NMAX 338 C
274 NTDR = NDKJ + KK*KK*NMAX 339 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
275 NYV = NTDR + KK*NMAX 340 COMMON /RAD/ PMAC, NRAD ,NNARROW
276 NABV = NYV + KK*NMAX 341 COMMON/CLAYER/ QL(100),QLS(100,600)
277 NBLW = NABV + NATJ*NMAX 342
278 NBUF = NBLW + NATJ*NMAX 343 C
279 NTWP = NBUF + NATJ*NMAX 344 C
280 NS = NTWP + LENTWP 345 DIMENSION ICKWRK(*), RCKWRK(*), IMCWRK(*), RMCWRK(*), YOXID(*),
281 NSN = NS + NATJ*NMAX 346 1 YFUEL(*), WT(*), FUEL(*), PROD(*), OXID(*), X(*),
282 NFF = NSN + NATJ*NMAX 347 2 VISC(*), COND(*), D(KK,*), TDR(KK,*), YV(KK,*),
283 NFN = NFF + NATJ*NMAX 348 3 DKJ(KK,KK,*), S(NATJ,*), SN(NATJ,*), F(NATJ,*),
284 NDS = NFN + NATJ*NMAX 349 4 XGIVEN(*), TGIVEN(*), SCRCHK(KK,5), KW(6), XMF(KK)
285 NSSV = NDS + NMAX 350 C
286 NA = NSSV + NMAX 351 C EQUIL SPACE
287 C NTOT = NA + (6*NATJ-2) * (NATJ*NMAX) - 1 352 C
288 NEQW = NA + (6*NATJ-2) * (NATJ*NMAX) - 1 353 DIMENSION IEQWRK(LENIEQ), REQWRK(LENREQ), REAC(KK,2), DCS(KK)
289 NREAC = NEQW + LENREQ 354 C
290 NDCS = NREAC + 2*KK 355 C DIMENSION NEWTON SPACE
291 NTOT = NDCS + KK 356 C
292 C 357 DIMENSION ABOVE(NATJ,*), BELOW(NATJ,*), BUFFER(NATJ,*),
293 C APPORTION THE INTEGER SPACE 358 1 TWPWK(*), ITWPWK(*), A(6 * NATJ - 2, *), IP(NATJ, *),
294 C 359 3 FN(NATJ,*), DS(*), SSAVE(*), LEVEL(2)
295 ITPW = ITOT 360 C
296 IIP = ITPW + LENITW 361 CHARACTER KSYM(*)*(*), CCKWRK(*)*(*), ATOM(*)*(*), LINE*80
297 C ITOT = IIP + NATJ*NMAX - 1 362 C
298 IEQW = IIP + NATJ*NMAX - 1 363 LOGICAL LTIME, LTIME2, LENRGY, LMULTI, LTDIF, LUMESH, LRSTRT,
299 ITOT = IEQW + LENIEQ 364 1 LCNTUE, LSEN, LVARMC, RSTCNT, ERROR, FUNCTN, JACOBN,
300 C 365 2 REENTR, SOLVE, STORE, SUCCES, ADAPT, SHOW, SAVE, UPDATE,
301 C APPORTION THE LOGICAL SPACE 366 3 ACTIVE(*), MARK(*), ENERGY, LUSTGV, LREGRD, LRADI,LNARR
302 C 367 C
303 LAC = 1 368 INTEGER CALL, CALLS
304 LMK = LAC + NATJ 369 C
305 LTOT = LMK + NMAX - 1 370 DOUBLE PRECISION XFRACT(KK)
306 C 371
307 C APPORTION THE CHARACTER SPACE 372 CHARACTER*16 ISOLUT, ISENSI, ICHR, ICKLNK, IMCLNK
308 C 373 LOGICAL IERR, LEQUIL
309 IKS = ICTOT 374 DATA ISOLUT/'SOLUTION '/, ISENSI/'SENSITIVITY '/,
310 IATOM = IKS + KK 375 1 ICKLNK/'CKLINK '/, IMCLNK/'MCLINK '/
311 ICTOT = IATOM + MM 376 DATA ADAFLR /1.0E-08/, LCNTUE/.FALSE./, RFAC/1.0/
312 RETURN 377 DATA LINE/'CO2 H2O CH4 CO O2 N2'/
313 END 378 C
314 C 379 C
315 C---------------------------------------------------------------------- 380 CALL CKSYMS (CCKWRK, LOUT, KSYM, IERR)
316 C 381 C
317 SUBROUTINE FLDRIV (LENITW, LENTWP, LIN, LOUT, 382 CALL CKCRAY (LINE, KK, KSYM, LOUT, 6, NNARROW, NFD, IERR)
318 1 LREST, LSAVE, LRCRVR, KK, II, MM, NATJ, NMAX, 383
319 2 LENICK, LENRCK, RCKWRK, RMCWRK, YOXID, YFUEL, 384 C COMPUTE THE UNIT ROUNDOFF, AND THE RELATIVE AND ABSOLUTE
320 3 WT, FUEL, PROD, OXID, SCRCHK, X, VISC, COND, 385 C PERTURBATIONS FOR THE JACOBIAN EVALUATION.
321 4 TGIVEN, XGIVEN, D, DKJ, TDR, YV, ABOVE, BELOW, 386 C
322 5 BUFFER, TWPWK, S, SN, F, FN, DS, SSAVE, A, 387 U = 1.0
323 6 ICKWRK, IMCWRK, ITWPWK, KSYM, CCKWRK, IP, 388 10 CONTINUE
324 7 ACTIVE, MARK, 389 U = U*0.5
325 C EQUIL ARRAYS... 390 COMP = 1.0 + U

391 IF (COMP .NE. 1.0) GO TO 10 456 C THIS IS A RESTART

392 ABSOL = SQRT(2.0*U) 457 C
393 RELAT = SQRT(2.0*U) 458 NREST = 0
394 C 459 320 CONTINUE
395 RSTCNT = .FALSE. 460 READ (LREST) ICHR
396 C 461 C
397 REWIND LRCRVR 462 C DON'T READ LINK FILES WITH SOLUTION.
398 C 463 IF (ICHR .EQ. ICKLNK) THEN
399 CALL CKSYMS (CCKWRK, LOUT, KSYM, IERR) 464 DO 321 L=1,4
400 CALL CKWT (ICKWRK, RCKWRK, WT) 465 READ (LREST)
401 CALL CKRP (ICKWRK, RCKWRK, RU, RUC, PATM) 466 321 CONTINUE
402 C 467 ELSEIF (ICHR .EQ. IMCLNK) THEN
403 200 CONTINUE 468 DO 322 L=1,3
404 C 469 READ (LREST)
405 C CALL THE KEYWORD INPUT 470 322 CONTINUE
406 C 471 ELSE
407 CALL RDKEY (KK, NMAX, LIN, LOUT, KSYM, PATM, LTIME, LTIME2, 472 IF (ICHR .EQ. ISOLUT) THEN
408 1 LUSTGV,LENRGY,LRADI,LNARR,LEQUIL,LMULTI,LTDIF,LUMESH, 473 READ (LREST) NNNN, JJ, DUM
409 2 LRSTRT, 474 READ (LREST) DUM, DUM
410 3 LCNTUE, IPROFL, IPRNT, MFILE, UFAC,DFAC,RATEF,N1CALL, 475 READ (LREST) (X(J), J=1,JJ)
411 4 LSEN, VFUEL, VOXID, AFUEL, AOXID, TFUEL, TOXID, TMAX, 476 READ (LREST) ((S(N,J), N=1,NNNN), J=1,JJ)
412 5 PR, JJ, X,FUEL, PROD, OXID, XCEN, XEND, WMIX, 477 IF (NNNN .NE. NATJ) THEN
413 6 GRAD, CURV, NADP, IRETIR, SFLR, NTEMP, XGIVEN, TGIVEN, 478 WRITE (LOUT, *)
414 7 ATOL, RTOL, ATIM, RTIM, NUMDT, DT1, NUMDT2, DT2, 479 1 ' FATAL ERROR, INCOMPATIBLE RESTART FILE'
415 8 DTMIN, WNDFAC, LREGRD, JJREGD, PCTADP, RATGTC, 480 STOP
416 9 KW, NW, LFXTEQ, NJAC, NINIT, ITJAC, DTMAX ) 481 ENDIF
417 C 482 NREST = NREST + 1
418 C 483 IF (NREST .EQ. MFILE) GO TO 350
419 C SET THE SOLUTION BOUNDS 484 ELSE IF (ICHR .EQ. ISENSI) THEN
420 C 485 DO 310 I = 1, II
421 DO 100 J = 1, NMAX 486 READ (LREST) IS, ((SN(N,J),N=1,NATJ), J=1,JJ)
422 BELOW(NT,J) = 200. 487 310 CONTINUE
423 ABOVE(NT,J) = 6000.0E0 488 ELSE
424 BELOW(NG,J) = -10000. 489 WRITE (LOUT, *)
425 ABOVE(NG,J) = 10000. 490 1 'FATAL ERROR, NOT A SOLUTION ON RESTART FILE'
426 BELOW(NH,J) = -100.E10 491 STOP
427 ABOVE(NH,J) = 100.E10 492 ENDIF
428 BELOW(NF,J) = -10000. 493 ENDIF
429 ABOVE(NF,J) = 10000. 494 GO TO 320
430 DO 100 K = 1, KK 495 350 CONTINUE
431 BELOW (NYS+K, J) = SFLR 496 IF (NREST .NE. MFILE) THEN
432 ABOVE (NYS+K, J) = 10. 497 WRITE (LOUT, *) ' Error reading solution file...'
433 100 CONTINUE 498 STOP
434 C 499 ENDIF
435 ENERGY = LENRGY 500 C
436 C 501 ENDIF
437 C 502 C
438 C SET THE VARIABLES ON WHICH TO ADAPT 503 C LIMIT SPECIES MINIMUM ON RESTART
439 C 504 C
440 DO 300 N = 1, NATJ 505 CC DO 326 J = 2, JJ
441 ACTIVE(N) = .TRUE. 506 CC DO 325 K = 1, KK
442 300 CONTINUE 507 CC
443 C 508 CC*****precision > single
444 IF (IPRNT .LT. 10) THEN 509 CC S(NYS+K,J) = MAX( 1.E-15, S(NYS+K,J) )
445 LEVEL(1) = MIN (2, IPRNT) 510 CC*****END precision > single
446 LEVEL(2) = LEVEL(1) 511 CC*****precision > double
447 ELSE 512 CC S(NYS+K,J) = MAX( 1.D-15, S(NYS+K,J) )
448 LEVEL(1) = IPRNT/10 513 CC*****END precision > double
449 LEVEL(2) = IPRNT - 10*LEVEL(1) 514 CC
450 LEVEL(1) = MAX( LEVEL(1), LEVEL(2) ) 515 CC325 CONTINUE
451 ENDIF 516 CC326 CONTINUE
452 C 517 C
453 IF (LRSTRT) THEN 518 CALL RESTRT (KK, NMAX, NATJ, JJ, LOUT, LUSTGV, FUEL,
454 IF (.NOT. RSTCNT) THEN 519 1 OXID, NTEMP, XGIVEN, TGIVEN, XEND,
455 C 520 2 ICKWRK, RCKWRK, YOXID, YFUEL, X, S)
521 C 586 CALLS = 1
522 C IF (RSTCNT .AND. LREGRD) THEN 587 ENDIF
523 IF (LREGRD) THEN 588 C
524 WRITE (LOUT, *) ' REGRIDDING TO ', JJREGD, ' POINTS' 589 C/// TOP OF THE LOOP OVER CALLS TO TWOPNT.
525 CALL REGRID (SN(1,2), S(1,2), NATJ, JJREGD-1, JJ-1, 590 C
526 1 VISC(2), X(2), COND, PCTADP, RATGTC, NT) 591 C
527 JJ = JJREGD 592 DO 1100 CALL = N1CALL, CALLS
528 DO 380 J = 2, JJ 593 C
529 X(J) = VISC(J) 594 IF (CALL .EQ. 1) THEN
530 DO 370 N = 1, NH 595 LENRGY = .FALSE.
531 S(N,J) = SN(N,J) 596 ADAPT = .FALSE.
532 370 CONTINUE 597 ELSEIF (CALL .EQ. 2) THEN
533 DO 375 K = 1, KK 598 IF (LEQUIL) THEN
534 C 599 PA = PR / PATM
535 C*****precision > single 600 CALL EQGUES
536 C S(NYS+K,J) = MAX( 1.E-15, SN(NYS+K,J) ) 601 1 ( JJ, KK, MM, LOUT, NATJ, S, PA, ATOM, KSYM,
537 C*****END precision > single 602 2 ICKWRK, LENICK, RCKWRK, LENRCK, IEQWRK, LENIEQ, REQWRK,
538 C*****precision > double 603 3 LENREQ, REAC, DCS, LFXTEQ )
539 S(NYS+K,J) = MAX( 1.D-15, SN(NYS+K,J) ) 604 NTEMP = JJ
540 C*****END precision > double 605 DO 450 N = 1, NTEMP
541 C 606 XGIVEN(N) = X(N)
542 375 CONTINUE 607 TGIVEN(N) = S(NT,N)
543 380 CONTINUE 608 450 CONTINUE
544 C 609 ELSE
545 NTEMP = JJ 610 LENRGY = ENERGY
546 DO 390 N = 1, NTEMP 611 ADAPT = .TRUE.
547 XGIVEN(N) = X(N) 612 WRITE (LOUT,'(/A/)')
548 TGIVEN(N) = S(NT,N) 613 1 ' FLDRIV: FINISHED FIXED TEMPERATURE, ADDING ENERGY EQUATION'
549 390 CONTINUE 614 ENDIF
550 ENDIF 615 ELSEIF (CALL .EQ. 3) THEN
551 C 616 LENRGY = ENERGY
552 ELSE 617 ADAPT = .TRUE.
553 C 618 WRITE (LOUT,'(/A/)')
554 C SET THE STARTING PROFILES 619 1 ' FLDRIV: FINISHED FIXED TEMPERATURE, ADDING ENERGY EQUATION'
555 C 620 ENDIF
556 CALL START (KK, NMAX, NATJ, JJ, LOUT, LUMESH, IPROFL, TMAX, 621 C
557 1 TFUEL, TOXID, VFUEL, VOXID, PR, 622 IF (LENRGY) RFAC = RATEF
558 2 FUEL, PROD, OXID, NTEMP, XGIVEN, TGIVEN, XCEN, 623 C
559 3 XEND, WMIX, ICKWRK, RCKWRK, SCRCHK(1,4), YOXID, 624 IF ((LTIME2) .AND. CALL.GT.1) THEN
560 4 YFUEL, X, S) 625 NUMDT = NUMDT2
561 C 626 DT1 = DT2
562 IF (LEQUIL .AND. (IPROFL.EQ.3) ) THEN 627 ENDIF
563 PA = PR / PATM 628 C
564 CALL EQGUES ( JJ, KK, MM, LOUT, NATJ, S, PA, ATOM, KSYM, 629 REENTR = .FALSE.
565 2 ICKWRK, LENICK, RCKWRK, LENRCK, IEQWRK, LENIEQ, REQWRK, 630 C
566 3 LENREQ, REAC, DCS, LFXTEQ ) 631 IPASSS = 1
567 NTEMP = JJ 632 500 CONTINUE
568 DO 420 N = 1, NTEMP 633 C
569 XGIVEN(N) = X(N) 634 CALL TWOPNT (ERROR, LOUT, LEVEL, LENITW, ITWPWK, LENTWP, TWPWK,
570 TGIVEN(N) = S(NT,N) 635 1 ABOVE, ACTIVE, ADAPT, BELOW, 0, BUFFER, NATJ,
571 420 CONTINUE 636 2 CONDIT, FUNCTN, JACOBN, MARK, X, IPASS,
572 LEQUIL = .FALSE. 637 3 IPASSS, NADP, NMAX, JJ, REENTR, IREPRT,
573 ENDIF 638 4 SAVE, 0, SHOW, SOLVE, ATOL, NJAC, RTOL,
574 C 639 5 NINIT, NUMDT, IRETIR, STORE, SUCCES,
575 ENDIF 640 6 ATIM, ITJAC, DFAC, RTIM, LTIME, UFAC, DTMAX, DTMIN,
576 C 641 7 ADAFLR, GRAD, CURV, DT1, DT, UPDATE, S)
577 400 CONTINUE 642 C
578 C 643 IF (ERROR) THEN
579 C HOW MANY CALLS TO TWOPNT 644 STOP
580 C 645 ELSE IF (.NOT.SUCCES .AND. .NOT.REENTR) THEN
581 IF (ENERGY .AND. LEQUIL ) THEN 646 IF (IREPRT .EQ. 2) WRITE (LOUT, *)
582 CALLS = 3 647 1 ' TWOPNT requires more mesh points, but NMAX too small'
583 ELSEIF (ENERGY .AND. .NOT. LEQUIL ) THEN 648 C
584 CALLS = 2 649 C
585 ELSE 650 ELSE IF (REENTR) THEN

651 C 716 C*****END precision > double

652 IF (FUNCTN) THEN 717 C
653 C 718 C*****precision > single
654 LVARMC = .TRUE. 719 C CALL SCOPY (NATJ*JJ, BUFFER, 1, SN, 1)
655 C 720 C*****END precision > single
656 C WRITE(*,*) 'First call to fun!,Line653' 721 C
657 CALL FUN (KK,JJ,NATJ,LENRGY,LRADI,LNARR,LMULTI,LTDIF,LVARMC, 722 ELSE IF (SHOW) THEN
658 1 LTIME, PR, WT, YOXID, YFUEL, DT, NTEMP, XGIVEN, 723 CALL PRINT (LOUT, KK, JJ, NATJ, PR, X, BUFFER, SCRCHK(1,1),
659 2 TGIVEN, X, SN, BUFFER, WNDFAC, SCRCHK(1,1), 724 1 KSYM, ICKWRK, RCKWRK, KW, NW)
660 3 SCRCHK(1,5), YV, SCRCHK(1,2), SCRCHK(1,3), 725 C
661 4 SCRCHK(1,4), TFUEL, TOXID, VFUEL, VOXID, 726 ELSE IF (SAVE) THEN
662 4 AFUEL, AOXID, 727 REWIND LRCRVR
663 5 VISC, COND, D, DKJ, TDR, 728 WRITE (LRCRVR) ISOLUT
664 6 ICKWRK, RCKWRK, IMCWRK, RMCWRK, F, RFAC) 729 WRITE (LRCRVR) NATJ, JJ, PR
665 C 730 WRITE (LRCRVR) VFUEL, VOXID
666 C*****precision > double 731 WRITE (LRCRVR) (X(J), J=1,JJ)
667 CALL DCOPY (NATJ*JJ, F, 1, BUFFER, 1) 732 WRITE (LRCRVR) ((BUFFER(N,J), N=1,NATJ), J=1,JJ)
668 C*****END precision > double 733 C
669 C 734 ELSE IF (UPDATE) THEN
670 C*****precision > single 735 IF (.NOT. LENRGY) THEN
671 C CALL SCOPY (NATJ*JJ, F, 1, BUFFER, 1) 736 DO 900 J = 1, JJ
672 C*****END precision > single 737 CALL TEMP (NTEMP, X(J), XGIVEN, TGIVEN, TI)
673 C 738 BUFFER(NT,J) = TI
674 C 739 900 CONTINUE
675 ELSE IF (JACOBN) THEN 740 ENDIF
676 C 741 C
677 CALL JACOB (KK, JJ, NATJ, LENRGY,LRADI, LNARR,LMULTI,LTDIF, 742 ENDIF
678 1 LTIME, PR, WT, YOXID, YFUEL, DT, NTEMP, XGIVEN, 743 C
679 2 TGIVEN, X, SN, BUFFER, WNDFAC, ABSOL, RELAT, 744 GO TO 500
680 3 SCRCHK, YV, TFUEL, TOXID, VFUEL, VOXID, 745 C
681 3 AFUEL, AOXID, 746 ENDIF
682 4 VISC, COND, D, DKJ, TDR, ICKWRK, RCKWRK, 747 C
683 5 IMCWRK, RMCWRK, F, FN, A, DS, SSAVE, RFAC) 748 1100 CONTINUE
684 C 749 C
685 C 750 C WRITE TO LSAVE WHEN SOLUTION IS COMPLETE
686 C*****precision > double 751 C
687 CALL DGBCO 752 IF (LEVEL(2) .EQ. 0)
688 C*****END precision > double 753 1 CALL PRINT (LOUT, KK, JJ, NATJ, PR, X, S, SCRCHK(1,1),
689 C*****precision > single 754 2 KSYM, ICKWRK, RCKWRK, KW, NW)
690 C CALL SGBCO 755 C
691 C*****END precision > single 756 WRITE (LSAVE) ISOLUT
692 + (A, 6 * NATJ - 2, NATJ * JJ, 2 * NATJ - 1, 2 * NATJ - 1, 757 WRITE (LSAVE) NATJ, JJ, PR
693 + IP, RCOND, FN) 758 WRITE (LSAVE) VFUEL, VOXID
694 C 759 WRITE (LSAVE) (X(J), J=1,JJ)
695 IF (RCOND .LE. 0.0E0) THEN 760 WRITE (LSAVE) ((S(N,J), N=1,NATJ), J=1,JJ)
696 WRITE (LOUT, *) ' FATAL ERROR, SINGULAR JACOBIAN ' 761 C
697 STOP 762 C
698 ENDIF 763 IF (LSEN) THEN
699 CONDIT = 1.0 / RCOND 764 C
700 C 765 LDA = 6*NATJ - 2
701 ELSE IF (SOLVE) THEN 766 CALL REASEN (II,KK,JJ,NATJ,LDA,LENRGY,LRADI,LNARR,LMULTI,LTDIF,
702 C 767 1 LSAVE, LOUT, LVARMC, LTIME, PR, WT,
703 C*****precision > double 768 2 YOXID, YFUEL, DT, NTEMP, XGIVEN,
704 CALL DGBSL 769 3 TGIVEN, X, SN, S, WNDFAC, ABSOL, RELAT,
705 C*****END precision > double 770 4 SCRCHK, YV, VISC, COND, D, DKJ, TDR, ICKWRK,
706 C*****precision > single 771 5 RCKWRK, IMCWRK, RMCWRK, F, FN, A, DS, SSAVE,
707 C CALL SGBSL 772 6 IP, RFAC)
708 C*****END precision > single 773 C
709 + (A, 6 * NATJ - 2, NATJ * JJ, 2 * NATJ - 1, 2 * NATJ - 1, 774 WRITE (LOUT,'(/A/)') ' SENSITIVITY CALCULATION COMPLETE'
710 + IP, BUFFER, 0) 775 C
711 C 776 ENDIF
712 ELSE IF (STORE) THEN 777 C
713 C 778 C CHECK FOR CONTINUATION
714 C*****precision > double 779 C
715 CALL DCOPY (NATJ*JJ, BUFFER, 1, SN, 1) 780 IF (LCNTUE) THEN
781 C 846
782 WRITE (LOUT,'(/////)') 847 CALL RADEMIS(KK, ICKWRK, RCKWRK, PR, BUFFER(NT,I), BUFFER(NY,I),
783 DO 1210 L = 1, 5 848 1 PMAC, NRAD, 4, GASEMI)
784 WRITE (LOUT, *) 849
785 1 ' ////////////////// CONTINUING TO NEW PROBLEM /////////////' 850 ! WRITE(LOUT,18) I,X(I),(BUFFER(NT,I)**4-298**4)*(5.67E-8)*4*GASEMI
786 1210 CONTINUE 851 18 FORMAT(I2, 1X, F7.3, 1X, E12.3)
787 WRITE (LOUT,'(/////)') 852
788 C 853 9993 CONTINUE
789 RSTCNT = .TRUE. 854
790 LRSTRT = .TRUE. 855 ENDIF
791 C 856
792 GO TO 200 857 STOP
793 ENDIF 858 C
794 C 859 END
795 C 860
796 C 861 C
797 IF (LNARR) THEN 862 C---------------------------------------------------------------------
798 C 863 C
799 OPEN(7,FILE='RC.DAT') 864 SUBROUTINE EQGUES
800 C 865 1 ( JJ, KK, MM, LOUT, NATJ, SOLN, PRES, ATOM, KSYM,
801 WRITE(7,9999) JJ-1 866 2 ICKWRK, LENICK, RCKWRK, LENRCK, IEQWRK, LENIEQ, REQWRK,
802 9999 FORMAT(I2) 867 3 LENREQ, REAC, DCS, LFXTEQ )
803 C 868 C
804 DO 9998 I=1,JJ-1 869 C*****precision > double
805 870 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
806 CALL CKYTX(BUFFER(NY,I),ICKWRK, RCKWRK,XFRACT) 871 C*****END precision > double
807 872 C
808 DELTAX=(X(I+1)-X(I))/100 873 C*****precision > single
809 C 874 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
810 WRITE(7,9997) DELTAX,BUFFER(NT,I), 875 C*****END precision > single
811 1 (XFRACT(NNARROW(K))*101.,K=1,6),0.0 876 C
812 C 877 PARAMETER (NMAX=1)
813 9997 FORMAT(F8.5,1X,F7.2,1X,7(D9.3,1X)) 878 DIMENSION ICKWRK(LENICK), RCKWRK(LENRCK), IEQWRK(LENIEQ),
814 879 1 REQWRK(LENREQ), REAC(KK,2), DCS(*),
815 9998 CONTINUE 880 4 XCON(NMAX), KCON(NMAX), SOLN(NATJ,*)
816 C 881 C
817 C 882 CHARACTER ATOM(*)*(*), KSYM(*)*(*)
818 WRITE(7,9996) 298.0,500.0,10000.0 883 C
819 C 884 LOGICAL EQST, LFXTEQ
820 9996 FORMAT(F5.1,1X,F5.1,1X,F7.1) 885 C
821 C 886 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
822 WRITE(7,9995) 0 887 C
823 C 888 DATA EQST/.FALSE./, KMON/0/, NCON/0/
824 9995 FORMAT(I1) 889 C
825 C 890 IF (LFXTEQ) THEN
826 CLOSE(7) 891 NOP = 1
827 C 892 ELSE
828 WRITE(LOUT,15) 893 NOP = 5
829 15 FORMAT(3X,'X(cm) DX(cm) QR_NARR(W/m3)') 894 ENDIF
830 895 C
831 DO 9994 I=1,JJ-1 896 C LOOP OVER INNER GRID POINTS, COMPUTE LOCAL EQUIL
832 897 C
833 9994 WRITE(LOUT,16) I,X(I),X(I+1)-X(I), 898 DO 100 J = 2, JJ-1
834 1 QL(I)*3.14159*2./((X(I+1)-X(I))/100) 899 C
835 900 C PASS IN SPECIES MOLE FRACTIONS
836 16 FORMAT(I2,1X,F7.3,1X,F7.3,1X,E12.3) 901 C
837 902 CALL CKYTX (SOLN(NY,J), ICKWRK, RCKWRK, REAC(1,1))
838 ENDIF 903 C
839 904 TE = 0.0
840 IF(LRADI) THEN 905 PE = 0.0
841 906 CALL EQUIL (LOUT, .FALSE., 0, EQST, .FALSE., ICKWRK, RCKWRK,
842 WRITE(LOUT,17) 907 1 LENIEQ, IEQWRK, LENREQ, REQWRK, MM, KK, ATOM,
843 17 FORMAT(3X,'X(cm) QR_THIN(W/m3)') 908 2 KSYM, NOP, KMON, REAC(1,1), SOLN(NT,J), TE,
844 909 3 PRES, PE, NCON, KCON, XCON)
845 DO 9993 I=1,JJ 910 C

911 CALL EQSOL (KK, REQWRK, REAC(1,2), DCS, SOLN(NT,J), PDUM, 976 ETAJ = (J-1)*DETA
912 1 HDUM, VDUM, SDUM, WMDUM, CDUM, CDET) 977 DO 70 I = ISTART, JJOLD
913 C 978 IF (ETAJ .LE. WORK(I)) THEN
914 CALL CKXTY (REAC(1,2), ICKWRK, RCKWRK, SOLN(NY,J)) 979 DEL = (ETAJ-WORK(I-1))/(WORK(I)-WORK(I-1))
915 100 CONTINUE 980 XNEW(J) = XOLD(I-1)+(XOLD(I)-XOLD(I-1))*DEL
916 C 981 GO TO 80
917 RETURN 982 ELSE
918 END 983 ISTART = I
919 C 984 ENDIF
920 C--------------------------------------------------------------------- 985 70 CONTINUE
921 C 986 WRITE (6, *) ' *** VALUE OF ETA NOT FOUND ***'
922 SUBROUTINE REGRID (SNEW, SOLD, NVAR, JJNEW, JJOLD, XNEW, XOLD, 987 80 CONTINUE
923 1 WORK, PR, R, N ) 988 C
924 C 989 C interpolate solution...
925 C*****precision > double 990 C
926 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 991 CALL INTPL8 (SOLD, SNEW, XOLD, XNEW, NVAR, JJOLD, JJNEW)
927 C*****END precision > double 992 C
928 C 993 RETURN
929 C*****precision > single 994 END
930 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 995 C
931 C*****END precision > single 996 C------------------------------------------------------------------
932 C 997 SUBROUTINE INTPL8 (F1, F2, X1, X2, MVAR, N1, N2)
933 DIMENSION SNEW(NVAR,*), SOLD(NVAR,*), XNEW(*), XOLD(*), WORK(*) 998 C------------------------------------------------------------------
934 C 999 C
935 C interpolate the solution onto an equidistributing mesh 1000 C interpolate to get f2(x2) from f1(x1)
936 C 1001 C
937 C 1002 C
938 C compute weight coefficients 1003 C*****precision > double
939 C 1004 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
940 R0 = 1. - PR 1005 C*****END precision > double
941 R1 = PR *R /(R+1.) 1006 C
942 R2 = PR - R1 1007 C*****precision > single
943 TV1 = 0. 1008 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
944 DO 10 I = 2, JJOLD 1009 C*****END precision > single
945 TV1 = TV1 + ABS( SOLD(N,I) - SOLD(N,I-1) ) 1010 C
946 10 CONTINUE 1011 DIMENSION F1(MVAR,*), F2(MVAR,*), X1(*), X2(*)
947 TV2 = 0. 1012 DO 100 J = 2, N2-1
948 DO 20 I = 2, JJOLD-1 1013 XVAL = X2(J)
949 TV2 = TV2 + ABS( (SOLD(N,I+1)-SOLD(N,I))/(XOLD(I+1)-XOLD(I)) 1014 DO 50 I = 2, N1
950 1 - (SOLD(N,I)-SOLD(N,I-1))/(XOLD(I)-XOLD(I-1)) ) 1015 IF(XVAL.LE.X1(I)) THEN
951 20 CONTINUE 1016 DEL = (XVAL-X1(I-1))/(X1(I)-X1(I-1))
952 XLEN = XOLD(JJOLD) - XOLD(1) 1017 DO 40 L = 1, MVAR
953 B1 = R1 * XLEN /(R0 * TV1) 1018 F2(L,J)=F1(L,I-1)+(F1(L,I)-F1(L,I-1))*DEL
954 B2 = R2 * XLEN /(R0 * TV2) 1019 40 CONTINUE
955 C 1020 GOTO 80
956 C compute partial sums of weight function 1021 ENDIF
957 C 1022 50 CONTINUE
958 WORK(1) = 0. 1023 WRITE(7,*) ' *** STOP...INTERPOLATION ERROR.'
959 DO 50 I = 2, JJOLD 1024 80 CONTINUE
960 DX = XOLD(I) -XOLD(I-1) 1025 100 CONTINUE
961 WORK(I) = DX + B1*ABS( SOLD(N,I) - SOLD(N,I-1) ) + WORK(I-1) 1026 C
962 1 + B2*ABS( (SOLD(N,I+1)-SOLD(N,I))/(XOLD(I+1)-XOLD(I)) 1027 C endpoints..
963 2 - (SOLD(N,I)-SOLD(N,I-1))/(XOLD(I)-XOLD(I-1)) ) 1028 C
964 50 CONTINUE 1029 DO 110 L = 1, MVAR
965 DO 65 I = 2, JJOLD 1030 F2(L,1) = F1(L,1)
966 WORK(I) = WORK(I)/WORK(JJOLD) 1031 F2(L,N2) = F1(L,N1)
967 65 CONTINUE 1032 110 CONTINUE
968 C 1033 END
969 C interpolate onto uniform eta grid to find new x 1034 C
970 C 1035 C-------------------------------------------------------------------
971 XNEW(1) = XOLD(1) 1036 C
972 XNEW(JJNEW) = XOLD(JJOLD) 1037 SUBROUTINE JACOB(KK,POINTS,COMPS,LENRGY,LRADI,LNARR,LMULTI,LTDIF,
973 ISTART = 2 1038 1 LTIME, PR, WT, YOXID, YFUEL, DT,
974 DETA = 1./FLOAT(JJNEW-1) 1039 2 NTEMP, XGIVEN, TGIVEN, MESH, SN, X0, WNDFAC,
975 DO 80 J = 2, JJNEW-1 1040 3 ABSOL, RELAT, SCRTCH, YV,
1041 4 TFUEL, TOXID, VFUEL, VOXID, AFUEL, AOXID, 1106 PERTRB(INDEX) = ABS(X0(COMP, POINT)) * RELAT + ABSOL
1042 4 VISC, COND, D, DKJ, 1107 X0(COMP, POINT) = X0(COMP, POINT) + PERTRB(INDEX)
1043 5 TDR, ICKWRK, RCKWRK, IMCWRK, RMCWRK, Y1, Y0, 1108 0100 CONTINUE
1044 6 A, PERTRB, SAVE, RFAC) 1109 C
1045 C 1110 C/// CALL THE FUNCTION AT THE PERTRBED X0 AND STORE THE RESULT IN Y1.
1046 C*****precision > double 1111 C
1047 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 1112 C WRITE(*,*) 'Third call to fun!,Line1049'
1048 DOUBLE PRECISION MESH 1113 CALL FUN(KK,POINTS,COMPS,LENRGY,LRADI,LNARR,LMULTI,LTDIF,.FALSE.,
1049 C*****END precision > double 1114 1 LTIME, PR, WT, YOXID, YFUEL, DT, NTEMP, XGIVEN,
1050 C 1115 2 TGIVEN, MESH, SN, X0, WNDFAC, SCRTCH(1, 1),
1051 C*****precision > single 1116 3 SCRTCH(1,5), YV, SCRTCH(1, 2), SCRTCH(1, 3),
1052 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 1117 4 SCRTCH(1, 4), TFUEL, TOXID, VFUEL, VOXID,
1053 C REAL MESH 1118 4 AFUEL, AOXID,
1054 C*****END precision > single 1119 5 VISC, COND, D, DKJ, TDR, ICKWRK, RCKWRK,
1055 C 1120 6 IMCWRK, RMCWRK, Y1, RFAC)
1056 INTEGER CLASS, COMP, COMPS, INDEX, LOWER, POINT, POINTS, ROWS, 1121 C
1057 1 UPPER 1122 C/// RESTORE X0 TO ITS ORIGINAL VALUE.
1058 LOGICAL LENRGY, LRADI, LNARR, LMULTI, LTDIF, LTIME 1123 C
1059 C 1124 INDEX = 0
1060 PARAMETER (LOWER = 1, UPPER = 1, MODULS = LOWER + 1 + UPPER) 1125 DO 0200 POINT = CLASS, POINTS, MODULS
1061 C 1126 INDEX = INDEX + 1
1062 DIMENSION A((2 * LOWER + UPPER + 3) * COMPS - 2, *), 1127 X0(COMP, POINT) = SAVE(INDEX)
1063 1 MESH(*), PERTRB(*), SAVE(*), SCRTCH(KK,*), 1128 0200 CONTINUE
1064 2 X0(COMPS, *), Y0(COMPS, *), Y1(COMPS, *) 1129 C
1065 C 1130 C/// DIFFERENCE TO GET THE COLUMNS OF THE JACOBIAN.
1066 KOFSET = (LOWER + UPPER + 2) * COMPS - 1 1131 C
1067 ROWS = (2 * LOWER + UPPER + 3) * COMPS - 2 1132 INDEX = 0
1068 C 1133 DO 0300 POINT = CLASS, POINTS, MODULS
1069 C/// ZERO THE MATRIX STORAGE SPACE. 1134 INDEX = INDEX + 1
1070 C 1135 TEMP = 1.0 / PERTRB(INDEX)
1071 ZERO = 0.0 1136 K = COMP + (POINT - 1) * COMPS
1072 C*****precision > double 1137 DO 0300 J2 = MAX (POINT - LOWER, 1),
1073 CALL DCOPY (ROWS * COMPS * POINTS, ZERO, 0, A, 1) 1138 + MIN (POINT + UPPER, POINTS)
1074 C*****END precision > double 1139 JOFSET = (J2 - 1) * COMPS - K + KOFSET
1075 C 1140 DO 0300 J1 = 1, COMPS
1076 C*****precision > single 1141 A(J1 + JOFSET, K) = (Y1(J1, J2) - Y0(J1, J2)) * TEMP
1077 C CALL SCOPY (ROWS * COMPS * POINTS, ZERO, 0, A, 1) 1142 0300 CONTINUE
1078 C*****END precision > single 1143 C
1079 C 1144 C/// BOTTOM OF THE LOOPS OVER THE RESIDUE CLASSES AND SOLUTION
1080 C 1145 C/// COMPONENTS.
1081 C/// CALL THE FUNCTION AT X0 AND STORE IN Y0. 1146 C
1082 C 1147 0400 CONTINUE
1083 C WRITE(*,*) 'Second call to fun!,Line1020' 1148 C
1084 CALL FUN (KK,POINTS,COMPS,LENRGY,LRADI,LNARR,LMULTI,LTDIF,.TRUE., 1149 RETURN
1085 1 LTIME, PR, WT, YOXID, YFUEL, DT, NTEMP, XGIVEN, 1150 END
1086 2 TGIVEN, MESH, SN, X0, WNDFAC, SCRTCH(1, 1), 1151 C
1087 3 SCRTCH(1,5), YV, SCRTCH(1, 2), SCRTCH(1, 3), 1152 C---------------------------------------------------------------------
1088 4 SCRTCH(1, 4), TFUEL, TOXID, VFUEL, VOXID, 1153 C
1089 4 AFUEL, AOXID, 1154 SUBROUTINE FUN (KK, JJ, NATJ, LENRGY,LRADI,LNARR,LMULTI, LTDIF,
1090 5 VISC, COND, D, DKJ, TDR, ICKWRK, RCKWRK, IMCWRK, 1155 1 LVARMC, LTIME, PR, WT, YOXID, YFUEL, DT, NTEMP,
1091 6 RMCWRK, Y0, RFAC) 1156 2 XGIVEN, TGIVEN, X, SN, S, WNDFAC, YAV, XAV, YV,
1092 C 1157 3 WDOT, CP, H, TFUEL, TOXID, VFUEL, VOXID,
1093 C 1158 4 AFUEL, AOXID, VISC,
1094 C/// TOP OF THE LOOPS OVER THE RESIDUE CLASSES AND SOLUTION COMPONENTS. 1159 5 COND, D, DKJ, TDR, ICKWRK, RCKWRK, IMCWRK, RMCWRK,
1095 C 1160 6 F, RFAC)
1096 DO 0400 CLASS = 1, MODULS 1161 C
1097 DO 0400 COMP = 1, COMPS 1162 C This subroutine forms the function for the differential equations
1098 C 1163 C Indicies:
1099 C/// FOR A GIVEN RESIDUE CLASS AND A GIVEN SOLUTION COMPONENT, 1164 C NT : Temperature
1100 C/// PERTRB THE X0 VECTOR AT POINTS IN THE SAME RESIDUE CLASS. 1165 C NG : Velocity gradient
1101 C 1166 C NF : Velocity
1102 INDEX = 0 1167 C NH : Eigenvalue, pressure gradient
1103 DO 0100 POINT = CLASS, POINTS, MODULS 1168 C KK : no. of species
1104 INDEX = INDEX + 1 1169 C JJ : no. of gridpoints
1105 SAVE(INDEX) = X0(COMP, POINT) 1170 C NATJ : no. variables at each point

1171 C LENERGY = .TRUE. if solve energy equation 1236 CALL CKRHOY (PR, TAV, YAV, ICKWRK, RCKWRK, RHOP)
1172 C LMULTI . 1237 C
1173 C LTDIFF 1238 DO 30 K = 1, KK
1174 C LVARMC 1239 C?? F(NYS+K, 1) = RHOP*YFUEL(K)*VFUEL
1175 C LTIME 1240 C?? 1 - RHOP*S(NYS+K,1)*VFUEL - RHOP*YV(K,1)
1176 C VFUEL, VOXID, TFUEL, TOXID, YFUEL, YOXID... 1241 F(NYS+K, 1) = S(NYS+K, 1) - YFUEL(K)
1177 C 1242 30 CONTINUE
1178 C--------------------------------------------------------------------- 1243 IF (LENRGY) THEN
1179 C 1244 F(NT,1) = TFUEL - S(NT,1)
1180 C*****precision > double 1245 ELSE
1181 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 1246 CALL TEMP (NTEMP, X(1), XGIVEN, TGIVEN, TI)
1182 C*****END precision > double 1247 F(NT, 1) = S(NT,1) - TI
1183 C 1248 ENDIF
1184 C*****precision > single 1249 F(NF,1) = S(NF,1) - VFUEL*RHOP/2.
1185 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 1250 F(NG,1) = AFUEL*RHOP - S(NG,1)
1186 C*****END precision > single 1251 F(NH,1) = S(NH,2) - S(NH,1)
1187 C 1252 C
1188 DIMENSION PMAC(7,4),NRAD(4), NNARROW(6) 1253 C INTERIOR MESH POINTS
1189 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY 1254 C
1190 C 1255 HASNARR=0.0
1191 COMMON/CLAYER/ QL(100),QLS(100,600) 1256 C
1192 C 1257 IF (LNARR) THEN
1193 COMMON/RCDATA/NOL,XLL(100),TL(100),RSC(7,100),WALLT,WAVMAX,WAVMIN 1258 C
1194 1259 C OPEN(7,FILE='RC.DAT')
1195 COMMON /RAD/ PMAC, NRAD, NNARROW 1260 C
1196 1261 C WRITE(7,9999) JJ-1
1197 DIMENSION WT(*), YOXID(*), YFUEL(*), XGIVEN(*), TGIVEN(*), X(*), 1262 C9999 FORMAT(I2)
1198 1 S(NATJ,*), SN(NATJ,*), YAV(*), XAV(*), YV(KK,*), 1263 C
1199 2 WDOT(*), CP(*), H(*), VISC(*), COND(*), D(KK,*), 1264 NOL = JJ-1
1200 3 TDR(KK,*), DKJ(KK,KK,*), ICKWRK(*), RCKWRK(*), 1265
1201 4 IMCWRK(*), RMCWRK(*), F(NATJ,*) 1266 DO 9998 I=1,JJ-1
1202 C 1267
1203 LOGICAL LENRGY,LRADI,LNARR,LMULTI, LTDIF, LVARMC, LTIME 1268 CALL CKYTX(S(NY,I),ICKWRK, RCKWRK,XFRACT)
1204 DOUBLE PRECISION XFRACT(KK) 1269
1205 C 1270 DELTAX=(X(I+1)-X(I))/100
1206 C 1271 C
1207 C timelimit 1272 C WRITE(7,9997) DELTAX,S(NT,I),
1208 C 1273 C 1 (XFRACT(NNARROW(K))*101.,K=1,6),0.0
1209 C*****unicos timelimit 1274 C
1210 C call tremain (secs) 1275 C9997 FORMAT(F8.5,1X,F7.2,1X,7(D9.3,1X))
1211 C if (secs .lt. 60.0) stop 1276 C
1212 C*****END unicos timelimit 1277 XLL(I) = DELTAX
1213 C 1278
1214 C EVALUATE AND STORE THE TRANSPORT COEFFICIENTS 1279 TL(I) = S(NT,I)
1215 C 1280
1216 C WRITE(*,*) 'Now in fun()!' 1281 DO 9997,K=1,6
1217 IF (LVARMC .AND. .NOT.LTIME) THEN 1282
1218 CALL MTRNPR (KK, JJ, NATJ, LENRGY, LMULTI, LTDIF, PR, X, S, 1283 RSC(K,I) = XFRACT(NNARROW(K))*101.
1219 1 YAV, ICKWRK, RCKWRK, IMCWRK, RMCWRK, 1284
1220 2 H, CP, XAV, VISC, COND, D, TDR, DKJ) 1285 9997 CONTINUE
1221 ENDIF 1286
1222 C 1287 RSC(7,I) = 0.
1223 C EVALUATE AND STORE THE DIFFUSION VELOCITIES 1288
1224 C (in the following call h(*) and cp(*) are used 1289 9998 CONTINUE
1225 C temporarily for scratch space) 1290 C
1226 C 1291 C
1227 CALL MDIFV (KK, JJ, NATJ, LMULTI, LTDIF, X, S, WT, YAV, 1292 C WRITE(7,9996) 298.0,500.0,10000.0
1228 1 H, CP, PR, D, TDR, ICKWRK, RCKWRK, YV, DKJ) 1293 C
1229 C 1294 C9996 FORMAT(F5.1,1X,F5.1,1X,F7.1)
1230 C FUEL BOUNDARY (X=0) 1295 C
1231 C 1296 C WRITE(7,9995) 0
1232 TAV = 0.5 * (S(NT,1) + S(NT,2)) 1297 C
1233 DO 10 K = 1, KK 1298 C9995 FORMAT(I1)
1234 YAV(K) = 0.5 * (S(NYS+K,1) + S(NYS+K,2)) 1299 C
1235 10 CONTINUE 1300 C
1301 WALLT = 298. 1366 WINDA = 0.
1302 1367 WINDB = 1.
1303 WAVMAX = 10000. 1368 WINDC = -1.
1304 1369 ENDIF
1305 WAVMIN = 500. 1370 DXWIND = WINDA*X(J+1) + WINDB*X(J) + WINDC*X(J-1)
1306 1371 ENDIF
1307 C CLOSE(7) 1372 C
1308 C 1373 C SPECIES CONSERVATION EQUATION
1309 CCCC CALL RADCAL 1374 C
1310 C 1375 IF (WNDFAC .EQ. 1.0) THEN
1311 1376 DO 200 K = 1, KK
1312 HASNARR = 1.0 1377 DYK = WINDA*S(NYS+K,J+1) + WINDB*S(NYS+K,J)
1313 C 1378 1 + WINDC*S(NYS+K,J-1)
1314 LENRGY = .TRUE. 1379 F(NYS+K,J) = 2.0*S(NF,J) * DYK / DXWIND
1315 1380 1 - WDOT(K) * WT(K)
1316 ENDIF 1381 2 + (RHOP*YV(K,J) - RHOM*YV(K,J-1)) / DXAV
1317 1382 200 CONTINUE
1318 DO 1000 J = 2, JJ-1 1383 ELSE
1319 C 1384 DO 210 K = 1, KK
1320 TAV = 0.5 * (S(NT,J) + S(NT,J+1)) 1385 F(NYS+K,J) = 2.0*S(NF,J) *
1321 DO 100 K = 1, KK 1386 1 (CENDFP*S(NYS+K,J+1) + CENDFC*S(NYS+K,J) +
1322 YAV(K) = 0.5 * (S(NYS+K,J) + S(NYS+K,J+1)) 1387 1 CENDFM*S(NYS+K,J-1) ) -
1323 100 CONTINUE 1388 2 WDOT(K) * WT(K) +
1324 C 1389 3 (RHOP*YV(K,J) - RHOM*YV(K,J-1)) / DXAV
1325 RHOM = RHOP 1390 210 CONTINUE
1326 CALL CKRHOY (PR, TAV, YAV, ICKWRK, RCKWRK, RHOP) 1391 ENDIF
1327 CALL CKRHOY (PR, S(NT,J), S(NY,J), ICKWRK, RCKWRK, RHOJ) 1392 C
1328 CALL CKRHOY (PR, S(NT,J+1), S(NY,J+1), ICKWRK, RCKWRK, RHOJP1) 1393 C STREAMFUNCTION EQUATION
1329 CALL CKRHOY (PR, S(NT,J-1), S(NY,J-1), ICKWRK, RCKWRK, RHOJM1) 1394 C
1330 C 1395 F(NF,J) = (S(NG,J)+S(NG,J-1))/2. - (S(NF,J) - S(NF,J-1))/DXM
1331 C FORM THE CHEMICAL RATE TERMS 1396 C
1332 C 1397 C MOMENTUM EQUATION
1333 CALL CKWYP (PR, S(NT,J), S(NY,J), ICKWRK, RCKWRK, WDOT) 1398 C
1334 CALL CKHML (S(NT,J), ICKWRK, RCKWRK, H) 1399 BIGCP = VISC(J)
1335 CALL CKCPBS (S(NT,J), S(NY,J), ICKWRK, RCKWRK, CPB) 1400 BIGCM = VISC(J-1)
1336 CALL CKCPMS (S(NT,J), ICKWRK, RCKWRK, CP) 1401 IF (WNDFAC .EQ. 1.0) THEN
1337 1402 DUGR = WINDA*( S(NF,J+1)*S(NG,J+1)/RHOJP1 )
1338 C 1403 1 + WINDB*( S(NF,J )*S(NG,J )/RHOJ )
1339 C ACCELERATE RATES TO FACILITATE SOLUTION? 1404 2 + WINDC*( S(NF,J-1)*S(NG,J-1)/RHOJM1 )
1340 C 1405 F(NG,J) = - 3.0*S(NG,J)**2/RHOJ +
1341 DO 120 K = 1, KK 1406 2 2.0 * DUGR / DXWIND
1342 WDOT(K) = WDOT(K) *RFAC 1407 3 - ( BIGCP * (S(NG,J+1)/RHOJP1 - S(NG,J)/RHOJ) / DXP -
1343 120 CONTINUE 1408 3 BIGCM * (S(NG,J)/RHOJ -S(NG,J-1)/RHOJM1)/DXM ) /
1344 C 1409 3 DXAV - S(NH,J)
1345 C FORM THE MESH DIFFERENCES 1410 ELSE
1346 C 1411 F(NG,J) = - 3.0*S(NG,J)**2/RHOJ +
1347 DXP = (X(J+1) - X(J) ) 1412 2 2.0 * (CENDFP*S(NG,J+1)*S(NF,J+1)/RHOJP1 +
1348 DXM = (X(J) - X(J-1)) 1413 2 CENDFC*S(NG,J)*S(NF,J)/RHOJ +
1349 DXAV = 0.5 * (X(J+1) - X(J-1)) 1414 2 CENDFM*S(NG,J-1)*S(NF,J-1)/RHOJM1 ) -
1350 DXPM = (X(J+1) - X(J-1)) 1415 3 ( BIGCP * (S(NG,J+1)/RHOJP1 - S(NG,J)/RHOJ) / DXP -
1351 C 1416 3 BIGCM * (S(NG,J)/RHOJ -S(NG,J-1)/RHOJM1)/DXM ) /
1352 C FORM THE COEFFICIENTS FOR CENTRAL DIFFERENCES 1417 3 DXAV -
1353 C 1418 4 S(NH,J)
1354 CENDFM = - DXP / (DXM*DXPM) 1419 ENDIF
1355 CENDFC = (DXP-DXM) / (DXP*DXM) 1420 C
1356 CENDFP = DXM / (DXP*DXPM) 1421 C ENERGY EQUATION
1357 C 1422 C
1358 C WINDWARD DIFFERENCING FACTORS 1423
1359 C 1424
1360 IF (WNDFAC .EQ. 1.0) THEN 1425 IF (LENRGY) THEN
1361 IF (S(NF,J) .LE. 0.) THEN 1426
1362 WINDA = 1. 1427 C Form the radiation coefficient of flame
1363 WINDB = -1. 1428
1364 WINDC = 0. 1429 CALL RADEMIS(KK, ICKWRK, RCKWRK, PR, S(NT,J), S(NY,J), PMAC,
1365 ELSE 1430 1 NRAD, 4, GASEMI)

1431 C 1496 CALL CKRHOY (PR, S(NT,JJ), S(NY,JJ), ICKWRK, RCKWRK, RHOJ)
1432 HASRAD = 0.0 1497 C
1433 1498 DO 1200 K = 1, KK
1434 IF (LRADI) THEN 1499 C.. F(NYS+K, JJ) = S(NYS+K,JJ) - YOXID(K)
1435 HASRAD = 1.0 1500 F(NYS+K, JJ) = RHOJ*YOXID(K)*VOXID
1436 ENDIF 1501 1 - RHOJ*S(NYS+K,JJ)*VOXID - RHOJ*YV(K,JJ-1)
1437 1502 1200 CONTINUE
1438 C*****precision > double 1503 C
1439 TDOT = DDOT (KK, WDOT, 1, H, 1) 1504 IF (LENRGY) THEN
1440 C*****END precision > double 1505 F(NT, JJ) = S(NT,JJ) - TOXID
1441 C*****precision > single 1506 ELSE
1442 C TDOT = SDOT (KK, WDOT, 1, H, 1) 1507 CALL TEMP (NTEMP, X(JJ), XGIVEN, TGIVEN, TI)
1443 C*****END precision > single 1508 F(NT, JJ) = S(NT,JJ) - TI
1444 C 1509 ENDIF
1445 SUM = 0.0 1510 C
1446 DO 400 K = 1, KK 1511 F(NH,JJ) = RHOJ*VOXID/2.0 - S(NF,JJ)
1447 SUM = SUM + 0.5 * (YV(K,J) + YV(K,J-1)) * 1512 F(NG,JJ) = S(NG,JJ) - AOXID*RHOJ
1448 1 CP(K) * (CENDFP*S(NT,J+1) + CENDFC*S(NT,J) + 1513 F(NF,JJ) = (S(NG,JJ)+S(NG,JJ-1))/2. - (S(NF,JJ) - S(NF,JJ-1))/DXP
1449 2 CENDFM*S(NT,J-1) ) 1514 C
1450 400 CONTINUE 1515 C ADD THE TIME STEP, IF NEEDED
1451 C 1516 C
1452 C WRITE(*,2999) HASNARR*QL(J)*3.14159*2/(X(J+1)-X(J))*1000 1517 IF (.NOT. LTIME) RETURN
1453 2999 FORMAT(8X,'Pr=',E12.6,'erg/cm3') 1518 C
1454 1519 DO 2500 J = 2, JJ-1
1455 IF (WNDFAC .EQ. 1.0) THEN 1520 C
1456 DTEMP = WINDA*S(NT,J+1) + WINDB*S(NT,J) + WINDC*S(NT,J-1) 1521 CALL CKRHOY (PR, S(NT,J), S(NY,J), ICKWRK, RCKWRK, RHO)
1457 F(NT,J) = 1522 C
1458 1 2.0*S(NF,J) * DTEMP / DXWIND - 1523 DO 2200 K = 1, KK-1
1459 1 ( COND(J)*(S(NT,J+1)-S(NT,J))/DXP - 1524 DYDT = (S(NYS+K,J) - SN(NYS+K,J)) / DT
1460 2 COND(J-1)*(S(NT,J)-S(NT,J-1))/DXM ) / 1525 F(NYS+K,J) = F(NYS+K,J) + RHO*DYDT
1461 3 (CPB*DXAV) + 1526 2200 CONTINUE
1462 4 RHOJ * SUM / CPB + 1527
1463 5 TDOT / CPB 1528 DGDT = (S(NG,J) - SN(NG,J)) / DT
1464 6 + HASRAD*(S(NT,J)**4-298.**4)*(5.67E-8)*4*10*GASEMI/CPB 1529 F(NG,J) = F(NG,J) + DGDT
1465 7 + HASNARR*QL(J)*3.14159*2/(X(J+1)-X(J))*1000./CPB 1530 C
1466 1531 IF (LENRGY) THEN
1467 ELSE 1532 DTDT = (S(NT,J) - SN(NT,J)) / DT
1468 F(NT,J) = 2.0*S(NF,J) * 1533 F(NT,J) = F(NT,J) + RHO*DTDT
1469 1 (CENDFP*S(NT,J+1) + CENDFC*S(NT,J) + 1534 ENDIF
1470 1 CENDFM*S(NT,J-1) ) - 1535 2500 CONTINUE
1471 1 ( COND(J)*(S(NT,J+1)-S(NT,J))/DXP - 1536 C
1472 2 COND(J-1)*(S(NT,J)-S(NT,J-1))/DXM ) / 1537 RETURN
1473 3 (CPB*DXAV) + 1538 END
1474 4 RHOJ * SUM / CPB + 1539 C--------------------------------------------------------------------
1475 5 TDOT / CPB 1540 SUBROUTINE MTRNPR (KK, JJ, NATJ, LENRGY, LMULTI, LTDIF, PR, X, S,
1476 6 + HASRAD*(S(NT,J)**4-298.**4)*(5.67E-8)*4*10*GASEMI/CPB 1541 1 YAV, ICKWRK, RCKWRK, IMCWRK, RMCWRK,
1477 7 + HASNARR*QL(J)*3.14159*2/(X(J+1)-X(J))*1000./CPB 1542 2 XMF, XMFP, XAV, VISC, COND, D, TDR, DKJ)
1478 1543 C
1479 ENDIF 1544 C*****precision > double
1480 1545 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
1481 1546 C*****END precision > double
1482 C 1547 C
1483 ELSE 1548 C*****precision > single
1484 CALL TEMP (NTEMP, X(J), XGIVEN, TGIVEN, TI) 1549 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
1485 F(NT, J) = S(NT,J) - TI 1550 C*****END precision > single
1486 ENDIF 1551 C
1487 C 1552 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
1488 C EIGENVALUE EQUATION, H 1553 C
1489 C 1554 DIMENSION X(*), S(NATJ,*), YAV(*), XAV(*), XMF(*),
1490 F(NH,J) = S(NH,J+1) - S(NH,J) 1555 1 XMFP(*), ICKWRK(*), RCKWRK(*), IMCWRK(*), RMCWRK(*),
1491 C 1556 2 VISC(*), COND(*), DKJ(KK,KK,*), D(KK,*), TDR(KK,*)
1492 1000 CONTINUE 1557 LOGICAL LENRGY, LTDIF, LMULTI
1493 C 1558 C
1494 C OXIDIZER BOUNDARY (X=L) 1559 DATA EPS/1.0E-30/
1495 C 1560 C
1561 IF (LMULTI) THEN 1626 1 XMF, XMFP, PR, D, TDR, ICKWRK, RCKWRK, YV, DKJ)
1562 C-----------------MULTICOMPONENT FORMULAS--------------------- 1627 C
1563 CALL CKYTX (S(NY,1), ICKWRK, RCKWRK, XMFP) 1628 C*****precision > double
1564 DO 200 J = 1, JJ-1 1629 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
1565 TAV = 0.5 * (S(NT,J) + S(NT,J+1)) 1630 C*****END precision > double
1566 C 1631 C
1567 C DIMENSIONAL TEMPERATURE AT THE GRID POINTS 1632 C*****precision > single
1568 C 1633 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
1569 DO 100 K = 1, KK 1634 C*****END precision > single
1570 YAV(K) = 0.5 * (S(NYS+K,J) + S(NYS+K,J+1)) 1635 C
1571 XMF(K) = XMFP(K) 1636 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
1572 100 CONTINUE 1637 C
1573 CALL CKYTX (YAV, ICKWRK, RCKWRK, XAV) 1638 DIMENSION X(*), S(NATJ,*), WT(*), YAV(*), XMF(*), XMFP(*),
1574 CALL CKYTX (S(NY,J+1), ICKWRK, RCKWRK, XMFP) 1639 1 D(KK,*), TDR(KK,*), DKJ(KK,KK,*), YV(KK,*),
1575 CALL CKMMWX (XAV, ICKWRK, RCKWRK, WTMAV) 1640 2 ICKWRK(*), RCKWRK(*)
1576 CALL MCMDIF (PR, TAV, XAV, KK, IMCWRK, RMCWRK, DKJ(1,1,J)) 1641 LOGICAL LTDIF, LDIRCT, LMULTI
1577 CALL MCAVIS (TAV, XAV, RMCWRK, VISC(J)) 1642 C
1578 DO 75 K = 1, KK 1643 LDIRCT = .TRUE.
1579 SUMN = 0.0 1644 C
1580 DO 50 L = 1, KK 1645 C
1581 CC SUMN = SUMN + WT(L) * DKJ(K,L,J) * 1646 CALL CKYTX (S(NY,1), ICKWRK, RCKWRK, XMFP)
1582 CC 1 (XMFP(L) - XMF(L)) / (X(J+1) - X(J)) 1647 C
1583 SUMN = SUMN + DKJ(K,L,J) * 1648 C LOOP OVER ALL MESH POINTS, COMPUTING THE DIFFUSION
1584 1 (S(NYS+L,J+1) - S(NYS+L,J)) / (X(J+1) - X(J)) 1649 C VELOCITY AT THE MID POINTS. THE INDEXING IS SUCH THAT
1585 50 CONTINUE 1650 C YV(K,J) IS THE DIFFUSION VELOCITY OF THE KTH SPECIES
1586 CC DENOM = - (XMFP(K) - XMF(K)) / (X(J+1) - X(J)) 1651 C MIDWAY BETWEEN NODES J AND J+1.
1587 DENOM = - (S(NYS+K,J+1) - S(NYS+K,J)) / (X(J+1) - X(J)) 1652 C
1588 D(K,J) = (SUMN + EPS) / ( WTMAV * (DENOM + EPS)) 1653 DO 1000 J = 1, JJ-1
1589 75 CONTINUE 1654 C
1590 C 1655 TMF = S(NT, J)
1591 C DETERMINE THE MIXTURE CONDUCTIVITY AND 1656 TMFP = S(NT, J+1)
1592 C THERMAL DIFFUSION COEFFICIENT AT J 1657 TAV = 0.5 * (TMF + TMFP)
1593 C 1658 DO 300 K = 1, KK
1594 IF (LENRGY .OR. LTDIF) 1659 YAV(K) = 0.5 * (S(NYS+K,J) + S(NYS+K,J+1))
1595 1 CALL MCMCDT (PR, TAV, XAV, IMCWRK, RMCWRK, 1660 XMF(K) = XMFP(K)
1596 2 ICKWRK, RCKWRK, TDR(1,J), COND(J)) 1661 300 CONTINUE
1597 C 1662 C
1598 200 CONTINUE 1663 CALL CKMMWY (YAV, ICKWRK, RCKWRK, WTM)
1599 RETURN 1664 CALL CKRHOY (PR, TAV, YAV, ICKWRK, RCKWRK, RHOAV)
1600 ELSE 1665 CALL CKYTX (S(NY,J+1), ICKWRK, RCKWRK, XMFP)
1601 C-----------------MIXTURE-AVERAGED FORMULAS--------------------- 1666 C
1602 C 1667 IF (LMULTI. AND. LDIRCT) THEN
1603 DO 400 J = 1, JJ-1 1668 C EVALUATE THE MULTICOMPONENT DIFFUSION VELOCITY DIRECTLY,
1604 TAV = 0.5 * (S(NT,J) + S(NT,J+1)) 1669 C RATHER THAN USE THE MIXTURE-AVERAGED FORM FOR D(K,J)
1605 C 1670 DO 475 K = 1, KK
1606 C DIMENSIONAL TEMPERATURE AT THE GRID POINTS 1671 SUM = 0.0
1607 C 1672 DO 450 L = 1, KK
1608 DO 300 K = 1, KK 1673 SUM = SUM + WT(L) * DKJ(K,L,J) *
1609 YAV(K) = 0.5 * (S(NYS+K,J) + S(NYS+K,J+1)) 1674 1 (XMFP(L)-XMF(L)) / (X(J+1)-X(J))
1610 300 CONTINUE 1675 450 CONTINUE
1611 CALL CKYTX (YAV, ICKWRK, RCKWRK, XAV) 1676 YV(K,J) = (WT(K)/WTM**2) * SUM
1612 CALL MCADIF (PR, TAV, XAV, RMCWRK, D(1,J)) 1677 475 CONTINUE
1613 CALL MCAVIS (TAV, XAV, RMCWRK, VISC(J)) 1678 ELSE
1614 C 1679 C USE MIXTURE-AVERAGED FORM FOR FICKIAN DIFFUSION,
1615 C DETERMINE THE MIXTURE CONDUCTIVITY AT J 1680 C WHETHER WE ARE USING THE MULTICOMPONENT FORMALISM
1616 C 1681 C OR MIXTURE-AVERAGED
1617 IF (LENRGY) CALL MCACON (TAV, XAV, RMCWRK, COND(J)) 1682 DO 500 K = 1, KK
1618 IF (LTDIF) CALL MCATDR (TAV, XAV, IMCWRK, RMCWRK, TDR(1,J)) 1683 YV(K,J) = - D(K,J) * (WT(K)/WTM) *
1619 C 1684 1 (XMFP(K)-XMF(K)) / (X(J+1)-X(J))
1620 400 CONTINUE 1685 500 CONTINUE
1621 ENDIF 1686 ENDIF
1622 RETURN 1687 C
1623 END 1688 C ADD THE THERMAL DIFFUSION, IF REQUESTED
1624 C-------------------------------------------------------------------- 1689 C
1625 SUBROUTINE MDIFV (KK, JJ, NATJ, LMULTI, LTDIF, X, S, WT, YAV, 1690 IF (LTDIF) THEN

1691 C 1756 K2 = L+KPERLN-1

1692 DO 600 K = 1, KK 1757 K2 = MIN (K2, KK)
1693 YV(K,J) = YV(K,J) - 1758 C
1694 1 (TDR(K,J) / (TAV*RHOAV)) * 1759 WRITE (LOUT, 7060) (KSYM(K), K=K1,K2)
1695 2 ( TMFP-TMF )/ (X(J+1)-X(J)) 1760 DO 200 J = 1, JJ
1696 600 CONTINUE 1761 CALL CKYTX (S(NY,J), ICKWRK, RCKWRK, XMF)
1697 C 1762 WRITE (LOUT, 7020) X(J), (XMF(K), K=K1,K2)
1698 ENDIF 1763 200 CONTINUE
1699 C 1764 C
1700 C ADD CORRECTION VELOCITY TO DIFFUSION 1765 ELSE
1701 C 1766 C
1702 SUM = 0. 1767 WRITE (LOUT, 7060) (KSYM(KW(K)), K=1,NW)
1703 DO 700 K = 1, KK 1768 DO 210 J = 1, JJ
1704 SUM = SUM + YV(K,J) 1769 CALL CKYTX (S(NY,J), ICKWRK, RCKWRK, XMF)
1705 700 CONTINUE 1770 C WRITE (LOUT, 7020) X(J), (S(NYS+KW(K),J), K=1,NW)
1706 VC = - SUM 1771 WRITE (LOUT, 7020) X(J), (XMF(KW(K)), K=1, NW)
1707 DO 800 K = 1, KK 1772 210 CONTINUE
1708 YV(K,J) = YV(K,J) + YAV(K)*VC 1773 ENDIF
1709 800 CONTINUE 1774 C
1710 1000 CONTINUE 1775 RETURN
1711 C 1776 C
1712 RETURN 1777 7020 FORMAT(1X, F6.3, 6(1PE11.3))
1713 END 1778 7060 FORMAT(/2X, 'X(cm)' , 3X, 10(A10, 1X))
1714 C-------------------------------------------------------------------- 1779 7070 FORMAT(/2X, 'X(cm)', 5X, 'F', 7X, 'V(cm/s)', 7X, 'G',
1715 SUBROUTINE PRINT (LOUT, KK, JJ, NATJ, PR, X, S, XMF, KSYM, 1780 1 8X, 'H', 10X, 'T(K)', 7X, 'RHO')
1716 1 ICKWRK, RCKWRK, KW, NW) 1781 C
1717 C 1782 END
1718 C*****precision > double 1783 C
1719 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 1784 C---------------------------------------------------------------------
1720 C*****END precision > double 1785 C
1721 C 1786 SUBROUTINE START (KK, NMAX, NATJ, JJ, LOUT, LUMESH, IPROFL, TMAX,
1722 C*****precision > single 1787 1 TFUEL, TOXID, VFUEL, VOXID, PR,
1723 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 1788 2 FUEL, PROD, OXID, NTEMP, XGIVEN, TGIVEN,
1724 C*****END precision > single 1789 3 XCEN, XEND, WMIX, ICKWRK, RCKWRK, Y,
1725 C 1790 4 YOXID, YFUEL, X, S)
1726 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY 1791 C
1727 C 1792 C*****precision > double
1728 DIMENSION X(*), S(NATJ, *), XMF(*), ICKWRK(*), RCKWRK(*), 1793 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
1729 1 KW(*) 1794 C*****END precision > double
1730 CHARACTER KSYM(*)*(*) 1795 C
1731 C 1796 C*****precision > single
1732 C 1797 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
1733 DATA KPERLN /6/ 1798 C*****END precision > single
1734 C 1799 C
1735 C 1800 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
1736 LS = 1 1801 C
1737 K2 = MIN (KPERLN, KK) 1802 DIMENSION FUEL(*), OXID(*), PROD(*),
1738 C 1803 1 ICKWRK(*), RCKWRK(*), Y(*), YOXID(*), YFUEL(*),
1739 C 1804 2 XGIVEN(*), TGIVEN(*), X(*), S(NATJ, *)
1740 C PRINT THE FLOW VARIABLES 1805 C
1741 C 1806 LOGICAL LUMESH
1742 WRITE (LOUT, 7070) 1807 C
1743 DO 100 J = 1, JJ 1808 C INITIALIZE MASS FLUX FRACTIONS AND MASS FRACTIONS TO 0.
1744 CALL CKRHOY (PR, S(NT,J), S(NY,J), ICKWRK, RCKWRK, RHO) 1809 C
1745 VEL = 2.0*S(NF,J)/RHO 1810 DO 100 K = 1, KK
1746 WRITE (LOUT, 7020) X(J), S(NF,J), VEL, S(NG,J), S(NH,J), 1811 YOXID(K) = 0.0
1747 1 S(NT,J), RHO 1812 YFUEL(K) = 0.0
1748 100 CONTINUE 1813 DO 100 J = 1, NMAX
1749 C 1814 S(NYS+K, J) = 0.0
1750 C PRINT THE MOLE FRACTIONS 1815 100 CONTINUE
1751 C 1816 C
1752 IF (NW .EQ. 0) THEN 1817 C SET THE MASS FLUX FRACTION BOUNDARY CONDITIONS
1753 C 1818 C
1754 DO 200 L = LS, KK, KPERLN 1819 CALL CKXTY (OXID, ICKWRK, RCKWRK, YOXID)
1755 K1 = L 1820 CALL CKXTY (FUEL, ICKWRK, RCKWRK, YFUEL)
1821 CALL CKXTY (PROD, ICKWRK, RCKWRK, Y ) 1886 CALL PLATOW (WMIX, XCEN, YFUEL(K), Y(K), YOXID(K),
1822 C 1887 1 X(1), X(J), X(JJ), S(NYS+K,J) )
1823 C COMPUTE STAGNATION PLANE LOCATION 1888 960 CONTINUE
1824 C 1889 DO 970 J = 1,JJ
1825 CALL CKRHOY (PR, TFUEL, YFUEL, ICKWRK, RCKWRK, RHOF) 1890 CALL PLATOW (WMIX, XCEN, TFUEL, TMAX, TOXID,
1826 CALL CKRHOY (PR, TOXID, YOXID, ICKWRK, RCKWRK, RHOO) 1891 1 X(1), X(J), X(JJ), S(NT,J) )
1827 XSTAG = XEND /( 1. + RHOO/RHOF*( (VOXID/VFUEL)**2 ) ) 1892 970 CONTINUE
1828 WRITE (LOUT,'(/1X,A,1PE10.3/)') 1893 C
1829 1'ESTIMATED STAGNATION LOCATION =', XSTAG 1894 ENDIF
1830 IF (XCEN .EQ. 0.) THEN 1895 C
1831 XCEN = XSTAG 1896 C CONVERT ALL STARTING ESTIMATES TO MASS FRACTION
1832 IF (LUMESH) THEN 1897 C NO NEED TO DO THIS IF SET PROFILE IN Y FIRST!
1833 WMIX = 2.*MIN( XEND-XCEN, XCEN ) 1898 CC
1834 ELSE 1899 C DO 1600 J = 1,JJ
1835 WMIX = 2.*MIN( X(JJ)-XCEN, XCEN-X(1) ) 1900 C CALL CKXTY (S(NY, J), ICKWRK, RCKWRK, Y)
1836 ENDIF 1901 C DO 1600 K = 1, KK
1837 ENDIF 1902 C S(NYS+K, J) = Y(K)
1838 C 1903 C1600 CONTINUE
1839 IF (LUMESH) THEN 1904 C
1840 C 1905 C SET THE 'GIVEN' TEMPERATURES TO THE COMPUTED PROFILE
1841 C SET UNIFORM X MESH COORDINATES 1906 C
1842 C 1907 NTEMP = JJ
1843 DX = (XEND-0.0) / FLOAT(JJ-1) 1908 DO 1770 N = 1, NTEMP
1844 DO 200 J = 1, JJ 1909 XGIVEN(N) = X(N)
1845 X(J) = 0.0 + DX*FLOAT(J-1) 1910 TGIVEN(N) = S(NT,N)
1846 200 CONTINUE 1911 1770 CONTINUE
1847 ENDIF 1912 C
1848 C 1913 C CALL CKRHOY (PR, S(NT,1 ), S(NY,1 ), ICKWRK, RCKWRK, RHOF)
1849 IF (IPROFL .EQ. 1) THEN 1914 C CALL CKRHOY (PR, S(NT,JJ), S(NY,JJ), ICKWRK, RCKWRK, RHOO)
1850 C 1915 FFUEL = RHOF*VFUEL/2.
1851 C SET TRIANGLE PROFILES 1916 FOXID = RHOO*VOXID/2.
1852 C 1917 DFDX = (FOXID - FFUEL)/(X(JJ) - X(1))
1853 DO 800 K = 1,KK 1918 DO 1800 J = 1, JJ
1854 DO 800 J = 1,JJ 1919 C
1855 CALL TRNGL (WMIX, XCEN, YFUEL(K), Y(K), YOXID(K), 1920 C SET A LINEAR F PROFILE
1856 1 X(J), S(NYS+K,J) ) 1921 C
1857 800 CONTINUE 1922 S(NF,J) = DFDX* (X(J)-X(1)) + FFUEL
1858 C 1923 C
1859 C SET THE TEMPERATURE PROFILE 1924 C SET G AS CONSTANT (TO MATCH LINEAR PROFILE IN F)
1860 C 1925 C
1861 DO 850 J = 1, JJ 1926 S(NG,J) = DFDX
1862 CALL TRNGL (WMIX, XCEN, TFUEL, TMAX, TOXID, 1927 C
1863 1 X(J), S(NT,J) ) 1928 C SET THE PRESSURE GRADIENT EIGENVALUE
1864 850 CONTINUE 1929 C
1865 C 1930 S(NH,J) = -100.
1866 ELSEIF (IPROFL .EQ. 2) THEN 1931 C
1867 C 1932 1800 CONTINUE
1868 C SET LINEAR PROFILES 1933 C
1869 C 1934 RETURN
1870 DO 900 K = 1,KK 1935 END
1871 DO 900 J = 1,JJ 1936 C
1872 CALL LINE (WMIX, XCEN, YFUEL(K), YOXID(K), 1937 C-------------------------------------------------------------------
1873 1 X(J), S(NYS+K,J) ) 1938 C
1874 900 CONTINUE 1939 SUBROUTINE TRNGL (WMIX, XCEN, FLOORL, FMAX, FLOORR, X, FVAL)
1875 DO 950 J = 1, JJ 1940 C
1876 S(NT,J) = TFUEL 1941 C*****precision > double
1877 950 CONTINUE 1942 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
1878 C 1943 C*****END precision > double
1879 C 1944 C
1880 ELSEIF (IPROFL .EQ. 3) THEN 1945 C*****precision > single
1881 C 1946 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
1882 C SET PLATEAU PROFILES 1947 C*****END precision > single
1883 C 1948 C
1884 DO 960 K = 1,KK 1949 IF (X .LE. (XCEN-WMIX/2.) ) THEN
1885 DO 960 J = 1,JJ 1950 FVAL = FLOORL

1951 RETURN 2016 WRITE (6,*) 'STOP, X NOT FOUND IN -PLATOW-'

1952 ELSE IF ((X .GT. (XCEN-WMIX/2.)) .AND. 2017 STOP
1953 1 (X .LE. XCEN) ) THEN 2018 ENDIF
1954 FVAL = (FMAX-FLOORL)/(0.5*WMIX) * (X-XCEN+WMIX*0.5) + FLOORL 2019 END
1955 RETURN 2020 C
1956 ELSE IF ((X .GT. XCEN) .AND. 2021 C-------------------------------------------------------------------
1957 1 (X .LE. (XCEN+WMIX/2.)) ) THEN 2022 C
1958 FVAL = (FLOORR-FMAX)/(0.5*WMIX) * (X-XCEN) + FMAX 2023 SUBROUTINE RESTRT (KK, NMAX, NATJ, JJ, LOUT, LUSTGV,
1959 RETURN 2024 1 FUEL, OXID, NTEMP, XGIVEN, TGIVEN, XEND,
1960 ELSE IF (X .GT. (XCEN+WMIX/2.) ) THEN 2025 2 ICKWRK, RCKWRK, YOXID, YFUEL, X, S)
1961 FVAL = FLOORR 2026 C
1962 RETURN 2027 C*****precision > double
1963 ENDIF 2028 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
1964 C 2029 C*****END precision > double
1965 WRITE (6,*) ' ERROR IN SUBROUTINE TRNGL...' 2030 C
1966 STOP 2031 C*****precision > single
1967 C 2032 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N)
1968 END 2033 C*****END precision > single
1969 C 2034 C
1970 C------------------------------------------------------------------- 2035 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY
1971 C 2036 C
1972 SUBROUTINE LINE (WMIX, XCEN, FLOORL, FLOORR, X, FVAL) 2037 DIMENSION FUEL(*), OXID(*),
1973 C 2038 1 ICKWRK(*), RCKWRK(*), YOXID(*), YFUEL(*),
1974 C*****precision > double 2039 2 XGIVEN(*), TGIVEN(*), X(*), S(NATJ, *)
1975 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 2040 C
1976 C*****END precision > double 2041 LOGICAL LUSTGV
1977 C 2042 C
1978 C*****precision > single 2043 C
1979 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 2044 C INITIALIZE MASS FLUX FRACTIONS TO 0.
1980 C*****END precision > single 2045 C
1981 C 2046 DO 100 K = 1, KK
1982 IF (X .LE. (XCEN-WMIX/2.) ) THEN 2047 YOXID(K) = 0.0
1983 FVAL = FLOORL 2048 YFUEL(K) = 0.0
1984 RETURN 2049 100 CONTINUE
1985 ELSE IF ( X .LT. (XCEN+WMIX/2.) ) THEN 2050 C
1986 FVAL = (FLOORR-FLOORL)/WMIX * (X-XCEN+WMIX*0.5) + FLOORL 2051 C IF A NEW XEND .GT. X(JJ), THEN ADD A POINT AT JJ+1
1987 RETURN 2052 C IF A NEW XEND .LE. X(JJ), THEN REDUCE JJ, AND SET X(JJ)=XEND
1988 ELSE 2053 C
1989 FVAL = FLOORR 2054 IF (XEND .GT. (X(JJ)+1.E-4) ) THEN
1990 RETURN 2055 JJ = JJ + 1
1991 ENDIF 2056 IF (JJ .GT. NMAX) THEN
1992 END 2057 WRITE (LOUT, *) ' ERROR...NEW XEND NEEDS TOO MANY POINTS'
1993 C 2058 STOP
1994 C------------------------------------------------------------------- 2059 ENDIF
1995 C 2060 X(JJ) = XEND
1996 SUBROUTINE PLATOW (W, XC, FL, FP, FR, X0, X, XL, F) 2061 DO 400 N = 1, NATJ
1997 C 2062 S(N,JJ) = S(N,JJ-1)
1998 C*****precision > double 2063 400 CONTINUE
1999 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 2064 ELSE
2000 C*****END precision > double 2065 C DO 500 J = 1, JJ
2001 C 2066 C IF (XEND .GE. X(J)) THEN
2002 C*****precision > single 2067 C X(J) = XEND
2003 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 2068 C GO TO 550
2004 C*****END precision > single 2069 C ENDIF
2005 C 2070 C500 CONTINUE
2006 IF (X .LE. (XC-W/2.) ) THEN 2071 C550 CONTINUE
2007 F = FL + (FP-FL)*(X-X0)/(XC-W/2.-X0) 2072 C JJ = J
2008 RETURN 2073 ENDIF
2009 ELSE IF ( X .LT. (XC+W/2.) ) THEN 2074 C
2010 F = FP 2075 C SET THE MASS FLUX FRACTION BOUNDARY CONDITIONS
2011 RETURN 2076 C
2012 ELSE IF ( X .LE. XL ) THEN 2077 CALL CKXTY (FUEL, ICKWRK, RCKWRK, YFUEL)
2013 F = FP + (FR-FP)*(X-(XC+W/2.))/(XL-(XC+W/2.)) 2078 CALL CKXTY (OXID, ICKWRK, RCKWRK, YOXID)
2014 RETURN 2079 C
2015 ELSE 2080 C SET XGIVEN AND TGIVEN TO THE OLD SOLUTION
2081 C 2146 OXID(K) = 0.
2082 IF (.NOT. LUSTGV) THEN 2147 PROD(K) = 0.
2083 NTEMP = JJ 2148 10 CONTINUE
2084 DO 1250 N = 1, NTEMP 2149 DO 11 K = 1, 6
2085 XGIVEN(N) = X(N) 2150 KW(K) = 0
2086 TGIVEN(N) = S(NT,N) 2151 11 CONTINUE
2087 1250 CONTINUE 2152 C
2088 ENDIF 2153 NPTS = 6
2089 C 2154 GRAD = 0.1
2090 C 2155 CURV = 0.5
2091 RETURN 2156 NADP = 3
2092 END 2157 IRETIR = 50
2093 C 2158 ATOL = 1.0E-9
2094 C-------------------------------------------------------------------- 2159 RTOL = 1.0E-4
2095 C 2160 ATIM = 1.0E-9
2096 SUBROUTINE RDKEY (KK, NMAX, LIN, LOUT, KSYM, PATM, LTIME, 2161 RTIM = 1.0E-4
2097 1 LTIME2, LUSTGV, LENRGY, LRADI, LNARR, 2162 SFLR = -5.E-4
2098 2 LEQUIL, LMULTI, LTDIF, 2163 NUMDT = 100
2099 3 LUMESH, LRSTRT, LCNTUE, IPROFL, IPRNT, MFILE, 2164 DT = 1.0E-6
2100 4 UFAC, DFAC, RATEF, N1CALL, LSEN, VFUEL, VOXID, 2165 NUMDT2= 100
2101 5 AFUEL, AOXID, TFUEL, TOXID, 2166 DT2 = 1.0E-6
2102 6 TMAX, PR, NPTS, X, FUEL, 2167 DTMIN = 1.E-10
2103 7 PROD, OXID, XCEN, XEND, WMIX, GRAD, 2168 NTEMP = 0
2104 8 CURV, NADP, IRETIR, SFLR, NTEMP, XX, TT, ATOL, 2169 NP = 0
2105 9 RTOL, ATIM, RTIM, NUMDT, DT, NUMDT2, DT2, DTMIN, 2170 NW = 0
2106 9 WNDFAC, LREGRD, JJREGD, PCTADP, RATGTC, 2171 WNDFAC= 1.0
2107 9 KW, NW, LFXTEQ, NJAC, NINIT, ITJAC, DTMAX ) 2172 VFUEL = 0.
2108 C 2173 VOXID = 0.
2109 C*****precision > double 2174 AFUEL = 0.
2110 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 2175 AOXID = 0.
2111 C*****END precision > double 2176 MFILE = 1
2112 C 2177 UFAC = 2.0
2113 C*****precision > single 2178 DFAC = 2.2
2114 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 2179 N1CALL= 1
2115 C*****END precision > single 2180 PR = PATM
2116 C 2181 TFUEL = 300.
2117 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY 2182 TOXID = 300.
2118 C 2183 TMAX = 2200.
2119 DIMENSION FUEL(*), OXID(*), PROD(*), 2184 JJREGD= 40
2120 1 XX(*), TT(*), X(*), VALUE(5), KW(*) 2185 PCTADP= .75
2121 C 2186 RATGTC= 1.0
2122 CHARACTER KEYWRD*4, KSYM(*)*(*), LINE*80 2187 IPRNT = 1
2123 C 2188 RATEF = 1.0
2124 LOGICAL LTIME, LTIME2, LENRGY, LMULTI, LTDIF, LUMESH, LRSTRT, 2189 NJAC = 20
2125 1 LCNTUE, LUSTGV, LSEN, NEC(8), NOPT(5), CNTNUD, LFIRST, 2190 NINIT = 0
2126 2 IERR, KERR, LREGRD, LEQUIL, LFXTEQ, LRADI, LNARR 2191 ITJAC = 20
2127 C 2192 DTMAX = 1.E-4
2128 C 2193 LFIRST= .TRUE.
2129 DATA NEC/8*.FALSE./, NOPT/5*.FALSE./ 2194 LUMESH= .TRUE.
2130 DATA CNTNUD/.FALSE./ 2195 LUSTGV= .FALSE.
2131 C 2196 LCNTUE= .FALSE.
2132 C INITIALIZE VARIABLES 2197 LRSTRT= .FALSE.
2133 C 2198 LTDIF = .FALSE.
2134 KERR = .FALSE. 2199 LMULTI= .FALSE.
2135 IF (LCNTUE) THEN 2200 LTIME = .FALSE.
2136 C 2201 LTIME2= .FALSE.
2137 LCNTUE = .FALSE. 2202 LENRGY= .TRUE.
2138 CNTNUD = .TRUE. 2203 LRADI = .FALSE.
2139 LFIRST = .TRUE. 2204 LNARR = .FALSE.
2140 NP = 0 2205 LSEN = .FALSE.
2141 C 2206 LREGRD= .FALSE.
2142 ELSE 2207 IPROFL= 1
2143 C 2208 LEQUIL= .FALSE.
2144 DO 10 K = 1, KK 2209 LFXTEQ= .FALSE.
2145 FUEL(K) = 0. 2210 ENDIF

2211 C 2276 C
2212 C-------------------------------------------------------------- 2277 C ABSOLUTE NEWTON ITERATION CONVERGENCE CRITERIA
2213 C 2278 C
2214 C READ NEXT INPUT LINE 2279 ELSE IF (KEYWRD .EQ. 'ATOL') THEN
2215 C 2280 CALL CKXNUM (LINE, 1, LOUT, NVAL, ATOL, IERR)
2216 WRITE (LOUT,'(/A/)') ' KEYWORD INPUT ' 2281 KERR = KERR.OR.IERR
2217 C 2282 C
2218 90 CONTINUE 2283 C RELATIVE NEWTON ITERATION CONVERGENCE CRITERIA
2219 KEYWRD = ' ' 2284 C
2220 LINE = ' ' 2285 ELSE IF (KEYWRD .EQ. 'RTOL') THEN
2221 READ (LIN, 7000) KEYWRD, LINE 2286 CALL CKXNUM (LINE, 1, LOUT, NVAL, RTOL, IERR)
2222 WRITE (LOUT, 8000) KEYWRD, LINE 2287 KERR = KERR.OR.IERR
2223 C 2288 C
2224 C IS THIS A KEYWORD COMMENT? 2289 C ABSOLUTE NEWTON CONVERGENCE CRITERIA FOR TIMESTEPS
2225 C 2290 C
2226 IF (KEYWRD(1:1) .EQ. '.' .OR. KEYWRD(1:1) .EQ. '/' 2291 ELSE IF (KEYWRD .EQ. 'ATIM') THEN
2227 1 .OR. KEYWRD(1:1) .EQ. '!') GO TO 90 2292 CALL CKXNUM (LINE, 1, LOUT, NVAL, ATIM, IERR)
2228 CALL UPCASE (KEYWRD) 2293 KERR = KERR.OR.IERR
2229 C 2294 C
2230 C--------------PROBLEM TYPE KEYWORDS-------------------- 2295 C RELATIVE NEWTON CONVERGENCE CRITERIA FOR TIMESTEPS
2231 C 2296 C
2232 C ENERGY EQUATION IS NOT INCLUDED 2297 ELSE IF (KEYWRD .EQ. 'RTIM') THEN
2233 C 2298 CALL CKXNUM (LINE, 1, LOUT, NVAL, RTIM, IERR)
2234 IF (KEYWRD .EQ. 'TGIV') THEN 2299 KERR = KERR.OR.IERR
2235 LENRGY = .FALSE. 2300 C
2236 C 2301 C TIME STEP STARTING PROCEDURE
2237 C ENERGY EQUATION IS INCLUDED 2302 C
2238 C 2303 ELSE IF (KEYWRD .EQ. 'TIME') THEN
2239 ELSE IF (KEYWRD .EQ. 'ENRG') THEN 2304 LTIME = .TRUE.
2240 LENRGY = .TRUE. 2305 CALL CKXNUM (LINE, 2, LOUT, NVAL, VALUE, IERR)
2241 C 2306 KERR = KERR.OR.IERR
2242 ELSE IF (KEYWRD .EQ. 'RADI') THEN 2307 NUMDT = INT(VALUE(1))
2243 LRADI = .TRUE. 2308 DT = VALUE(2)
2244 2309 C
2245 ELSE IF (KEYWRD .EQ. 'NARR') THEN 2310 C TIME STEPPING, AFTER ADDING THE ENERGY EQUATION
2246 LNARR = .TRUE. 2311 C
2247 2312 ELSE IF (KEYWRD .EQ. 'TIM2') THEN
2248 C FACTOR ON REACTION RATES 2313 LTIME2 = .TRUE.
2249 C 2314 CALL CKXNUM (LINE, 2, LOUT, NVAL, VALUE, IERR)
2250 ELSE IF (KEYWRD .EQ. 'GFAC') THEN 2315 KERR = KERR.OR.IERR
2251 CALL CKXNUM (LINE, 1, LOUT, NVAL, RATEF, IERR) 2316 NUMDT2 = INT(VALUE(1))
2252 KERR = KERR.OR.IERR 2317 DT2 = VALUE(2)
2253 C 2318 C
2254 C USE EQUILIBRIUM SOLUTION ESTIMATE 2319 C TIMESTEP INCREASE WHEN TIMESTEP DOES NOT CHANGE SOLUTION
2255 C 2320 C
2256 ELSE IF (KEYWRD .EQ. 'EQUL') THEN 2321 ELSE IF (KEYWRD .EQ. 'UFAC') THEN
2257 LEQUIL = .TRUE. 2322 CALL CKXNUM (LINE, 1, LOUT, NVAL, UFAC, IERR)
2258 C 2323 KERR = KERR.OR.IERR
2259 C FIX TEMP IN EQUIL SOLUTION ESTIMATE 2324 C
2260 C 2325 C TIMESTEP DECREASE WHEN NEWTON FAILS CONVERGENCE ON TIMESTEP
2261 ELSE IF (KEYWRD .EQ. 'FXEQ') THEN 2326 C
2262 LFXTEQ = .TRUE. 2327 ELSE IF (KEYWRD .EQ. 'DFAC') THEN
2263 C 2328 CALL CKXNUM (LINE, 1, LOUT, NVAL, DFAC, IERR)
2264 C LINEAR PROFILE ON INITIAL SOLUTION 2329 KERR = KERR.OR.IERR
2265 C 2330 C
2266 ELSE IF (KEYWRD .EQ. 'LINE') THEN 2331 C MINIMUM TIMESTEP
2267 IPROFL = 2 2332 C
2268 C 2333 ELSE IF (KEYWRD .EQ. 'DTMN') THEN
2269 C PROFILE ON INITIAL SOLUTION IS PLATEAU 2334 CALL CKXNUM (LINE, 1, LOUT, NVAL, DTMIN, IERR)
2270 C 2335 KERR = KERR.OR.IERR
2271 ELSE IF (KEYWRD .EQ. 'PLAT') THEN 2336 C
2272 IPROFL = 3 2337 C MAXIMUM TIMESTEP
2273 C 2338 C
2274 C--------------METHOD OPTIONS KEYWORDS-------------------- 2339 ELSE IF (KEYWRD .EQ. 'DTMX') THEN
2275 C 2340 CALL CKXNUM (LINE, 1, LOUT, NVAL, DTMAX, IERR)
2341 KERR = KERR.OR.IERR 2406 CALL CKXNUM (LINE, 1, LOUT, NVAL, GRAD, IERR)
2342 C 2407 KERR = KERR.OR.IERR
2343 C DO NOT DO THE FIXED TEMPERATURE PROBLEM 2408 C
2344 C 2409 C CURVATURE MESH ADAPTION PARAMETER
2345 ELSE IF (KEYWRD .EQ. 'NOFT') THEN 2410 C
2346 N1CALL = 2 2411 ELSE IF (KEYWRD .EQ. 'CURV') THEN
2347 C 2412 CALL CKXNUM (LINE, 1, LOUT, NVAL, CURV, IERR)
2348 C WINDWARD DIFFERENCING 2413 KERR = KERR.OR.IERR
2349 C 2414 C
2350 ELSE IF (KEYWRD .EQ. 'WDIF') THEN 2415 C NUMBER OF MESH POINTS TO ADD AT ONCE
2351 WNDFAC = 1.0 2416 C
2352 C 2417 ELSE IF (KEYWRD .EQ. 'NADP') THEN
2353 C CENTRAL DIFFERENCING 2418 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR)
2354 C 2419 KERR = KERR.OR.IERR
2355 ELSE IF (KEYWRD .EQ. 'CDIF') THEN 2420 NADP = INT(VALUE(1))
2356 WNDFAC = 0.0 2421 C
2357 C 2422 C RETIREMENT PERIOD BEFORE INCREASING THE TIMESTEP
2358 C FLOOR VALUE FOR THE SPECIES BOUNDS 2423 C
2359 C 2424 ELSE IF (KEYWRD .EQ. 'IRET') THEN
2360 ELSE IF (KEYWRD .EQ. 'SFLR') THEN 2425 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR)
2361 CALL CKXNUM (LINE, 1, LOUT, NVAL, SFLR, IERR) 2426 KERR = KERR.OR.IERR
2362 KERR = KERR.OR.IERR 2427 IRETIR = INT(VALUE(1))
2363 C 2428 C
2364 C OXIDIZER 2429 C INITIAL TIME STEPS BEFORE NEWTON
2365 C 2430 C
2366 ELSE IF (KEYWRD .EQ. 'KOUT') THEN 2431 ELSE IF (KEYWRD .EQ. 'ISTP') THEN
2367 CALL CKCRAY (LINE, KK, KSYM, LOUT, 6, KW, NFD, IERR) 2432 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR)
2368 IF (IERR) THEN 2433 KERR = KERR.OR.IERR
2369 WRITE (LOUT,'(A)') 2434 NINIT = INT(VALUE(1))
2370 1 ' ERROR READING KEYWRD '//KEYWRD 2435 C
2371 KERR = .TRUE. 2436 C RETIREMENT AGE OF JACOBIAN DURING NEWTON
2372 IF (NFD .GT. 6) THEN 2437 C
2373 WRITE (LOUT,'(A,I4,A)') 'FOUND ', NFD,' SPECIES' 2438 ELSE IF (KEYWRD .EQ. 'NJAC') THEN
2374 NW = 6 2439 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR)
2375 ENDIF 2440 KERR = KERR.OR.IERR
2376 ELSE 2441 NJAC = INT(VALUE(1))
2377 NW = NFD 2442 C
2378 ENDIF 2443 C RETIREMENT AGE OF JACOBIAN DURING TIME STEPPING
2379 C 2444 C
2380 C--------------GRID PARAMETER KEYWORDS-------------------- 2445 ELSE IF (KEYWRD .EQ. 'TJAC') THEN
2381 C 2446 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR)
2382 C 2447 KERR = KERR.OR.IERR
2383 C NUMBER OF INITIAL MESH POINTS 2448 ITJAC = INT(VALUE(1))
2384 C (THIS IS OVERWRITTEN 'GRID' INPUT) 2449 C
2385 C 2450 C CENTER OF MIXING REGION
2386 ELSE IF (KEYWRD .EQ. 'NPTS') THEN 2451 C
2387 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR) 2452 ELSE IF (KEYWRD .EQ. 'XCEN') THEN
2388 KERR = KERR.OR.IERR 2453 NOPT(2) = .TRUE.
2389 NPTS = INT(VALUE(1)) 2454 CALL CKXNUM (LINE, 1, LOUT, NVAL, XCEN, IERR)
2390 C 2455 KERR = KERR.OR.IERR
2391 C INITIAL MESH 2456 C
2392 C 2457 C DISTANCE AT WHICH END BOUNDARY CONDITION IS APPLIED
2393 ELSE IF (KEYWRD .EQ. 'GRID') THEN 2458 C
2394 LUMESH = .FALSE. 2459 ELSE IF (KEYWRD .EQ. 'XEND') THEN
2395 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR) 2460 NEC(1) = .TRUE.
2396 IF (IERR .OR. NP+1.GT.NMAX) THEN 2461 CALL CKXNUM (LINE, 1, LOUT, NVAL, XEND, IERR)
2397 KERR = .TRUE. 2462 KERR = KERR.OR.IERR
2398 ELSE 2463 C
2399 NP = NP + 1 2464 C WIDTH OF MIXING ZONE
2400 X(NP) = VALUE(1) 2465 C
2401 ENDIF 2466 ELSE IF (KEYWRD .EQ. 'WMIX') THEN
2402 C 2467 NOPT(1) = .TRUE.
2403 C GRADIENT MESH ADAPTION PARAMETER 2468 CALL CKXNUM (LINE, 1, LOUT, NVAL, WMIX, IERR)
2404 C 2469 KERR = KERR.OR.IERR
2405 ELSE IF (KEYWRD .EQ. 'GRAD') THEN 2470 C

2471 C--------------FLAME DEFINITION KEYWORDS-------------------- 2536 FUEL(KSPEC) = VALUE(1)

2472 C 2537 ENDIF
2473 C 2538 C
2474 C REACTANT INLET VELOCITY (r=R) 2539 C PRODUCT
2475 C 2540 C
2476 ELSE IF (KEYWRD .EQ. 'VFUE') THEN 2541 ELSE IF (KEYWRD .EQ. 'PROD') THEN
2477 NEC(4) = .TRUE. 2542 CALL CKSNUM (LINE, 1, LOUT, KSYM, KK, KSPEC, NVAL,
2478 CALL CKXNUM (LINE, 1, LOUT, NVAL, VFUEL, IERR) 2543 1 VALUE, IERR)
2479 KERR = KERR.OR.IERR 2544 IF (IERR) THEN
2480 ELSE IF (KEYWRD .EQ. 'VOXI') THEN 2545 WRITE (LOUT,'(A)')
2481 NEC(5) = .TRUE. 2546 1 ' ERROR READING KEYWRD '//KEYWRD
2482 CALL CKXNUM (LINE, 1, LOUT, NVAL, VOXID, IERR) 2547 KERR = .TRUE.
2483 KERR = KERR.OR.IERR 2548 ELSE
2484 VOXID = - VOXID 2549 PROD(KSPEC) = VALUE(1)
2485 C 2550 ENDIF
2486 C REACTANT INLET VELOCITY SLOPE (r=R) 2551 C
2487 C 2552 C OXIDIZER
2488 ELSE IF (KEYWRD .EQ. 'AFUE') THEN 2553 C
2489 CALL CKXNUM (LINE, 1, LOUT, NVAL, AFUEL, IERR) 2554 ELSE IF (KEYWRD .EQ. 'OXID') THEN
2490 KERR = KERR.OR.IERR 2555 CALL CKSNUM (LINE, 1, LOUT, KSYM, KK, KSPEC, NVAL,
2491 AFUEL = - AFUEL 2556 1 VALUE, IERR)
2492 ELSE IF (KEYWRD .EQ. 'AOXI') THEN 2557 IF (IERR) THEN
2493 CALL CKXNUM (LINE, 1, LOUT, NVAL, AOXID, IERR) 2558 WRITE (LOUT,'(A)')
2494 KERR = KERR.OR.IERR 2559 1 ' ERROR READING KEYWRD '//KEYWRD
2495 AOXID = - AOXID 2560 KERR = .TRUE.
2496 C 2561 ELSE
2497 C INLET TEMPERATURE 2562 OXID(KSPEC) = VALUE(1)
2498 C 2563 ENDIF
2499 ELSE IF (KEYWRD .EQ. 'TOXI') THEN 2564 C
2500 NEC(2) = .TRUE. 2565 C READ SPECIFIED TEMPERATURE PROFILE (X,T) PAIRS
2501 CALL CKXNUM (LINE, 1, LOUT, NVAL, TOXID, IERR) 2566 C
2502 KERR = KERR.OR.IERR 2567 ELSE IF (KEYWRD .EQ. 'TEMP') THEN
2503 ELSE IF (KEYWRD .EQ. 'TFUE') THEN 2568 CALL CKXNUM (LINE, 2, LOUT, NVAL, VALUE, IERR)
2504 NEC(3) = .TRUE. 2569 KERR = KERR.OR.IERR
2505 CALL CKXNUM (LINE, 1, LOUT, NVAL, TFUEL, IERR) 2570 IF (NTEMP+1 .GT. NMAX) THEN
2506 KERR = KERR.OR.IERR 2571 WRITE (LOUT, '(A,I4,A)')
2507 C 2572 1 ' ERROR... THE PROBLEM IS ONLY DIMENSIONED FOR ',
2508 C MAXIMUM TEMPERATURE 2573 2 ' (X,T) PAIRS'
2509 C 2574 ELSE
2510 ELSE IF (KEYWRD .EQ. 'TMAX') THEN 2575 NTEMP = NTEMP+1
2511 CALL CKXNUM (LINE, 1, LOUT, NVAL, TMAX, IERR) 2576 XX(NTEMP) = VALUE(1)
2512 KERR = KERR.OR.IERR 2577 TT(NTEMP) = VALUE(2)
2513 C 2578 ENDIF
2514 C PRESSURE 2579 C
2515 C 2580 C ON A RESTART USE GIVEN TEMPERATURE PROFILE, NOT THE ONE ON
2516 ELSE IF (KEYWRD .EQ. 'PRES') THEN 2581 C THE RESTART FILE
2517 CALL CKXNUM (LINE, 1, LOUT, NVAL, PR, IERR) 2582 C
2518 KERR = KERR.OR.IERR 2583 ELSE IF (KEYWRD .EQ. 'USTG') THEN
2519 PR = PR*PATM 2584 LUSTGV = .TRUE.
2520 C 2585 C
2521 C FUEL 2586 C--------------TRANSPORT OPTIONS KEYWORDS--------------------
2522 C 2587 C
2523 ELSE IF (KEYWRD .EQ. 'FUEL') THEN 2588 C
2524 IF (LFIRST) THEN 2589 C MULTICOMPONENT FORMULAS USED
2525 LFIRST = .FALSE. 2590 C
2526 DO 1100 K = 1, KK 2591 ELSE IF (KEYWRD .EQ. 'MULT') THEN
2527 FUEL(K) = 0. 2592 LMULTI = .TRUE.
2528 1100 CONTINUE 2593 C
2529 ENDIF 2594 C MIXTURE-AVERAGED FORMULAS USED
2530 CALL CKSNUM (LINE, 1, LOUT, KSYM, KK, KSPEC, NVAL, 2595 C
2531 1 VALUE, IERR) 2596 ELSE IF (KEYWRD(1:3) .EQ. 'MIX') THEN
2532 IF (IERR) THEN 2597 LMULTI = .FALSE.
2533 WRITE (LOUT,'(A)') 2598 C
2534 1 ' ERROR READING KEYWRD '//KEYWRD 2599 C
2535 ELSE 2600 C THERMAL DIFFUSION INCLUDED
2601 C 2666 C-------------THE KEYWORDS AFTER HERE ARE NOT OPERATIONAL------------
2602 ELSE IF (KEYWRD .EQ. 'TDIF') THEN 2667 C
2603 LTDIF = .TRUE. 2668 C--------------END OF KEYWORDS--------------------
2604 C 2669 C
2605 C--------------SENSITIVITY KEYWORDS-------------------- 2670 C
2606 C 2671 C TO GET HERE, AN INVALID KEYWORD WAS READ
2607 C 2672 C
2608 C ALL REACTION SENSITIVITY 2673 WRITE (LOUT, *) ' ERROR...ILLEGAL KEYWORD'
2609 C 2674 KERR = .TRUE.
2610 ELSE IF (KEYWRD .EQ. 'ASEN') THEN 2675 ENDIF
2611 LSEN = .TRUE. 2676 GO TO 90
2612 C 2677 C
2613 C--------------PRINTING AND RESTARTING KEYWORDS-------------------- 2678 C CHECK THE REACTANT AND PRODUCT SUMS
2614 C 2679 C
2615 C 2680 6000 CONTINUE
2616 C PRINT CONTROL 2681 IF (KERR) STOP
2617 C 2682 C
2618 ELSE IF (KEYWRD .EQ. 'PRNT') THEN 2683 SUMF = 0.
2619 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR) 2684 SUMO = 0.
2620 KERR = KERR.OR.IERR 2685 SUMP = 0.
2621 IPRNT = INT(VALUE(1)) 2686 DO 6100 K = 1, KK
2622 C 2687 SUMF = SUMF+FUEL(K)
2623 C RESTART SKIPS 2688 SUMO = SUMO+OXID(K)
2624 C 2689 SUMP = SUMP+PROD(K)
2625 ELSE IF (KEYWRD .EQ. 'SKIP') THEN 2690 6100 CONTINUE
2626 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR) 2691 C
2627 KERR = KERR.OR.IERR 2692 C NORMALIZE REACTANT AND PRODUCT FRACTIONS
2628 MFILE = INT(VALUE(1)) + 1 2693 C
2629 C 2694 DO 6200 K = 1, KK
2630 C RESTART CHECK 2695 FUEL(K) = FUEL(K)/SUMF
2631 C 2696 OXID(K) = OXID(K)/SUMO
2632 ELSE IF (KEYWRD .EQ. 'RSTR') THEN 2697 PROD(K) = PROD(K)/SUMP
2633 LRSTRT = .TRUE. 2698 6200 CONTINUE
2634 C 2699 C
2635 C CONTINUATION FLAG AND ASSOCIATED PARAMETERS 2700 IF (ABS(SUMF-1.0) .GT. 1.E-6) WRITE (LOUT, *)
2636 C 2701 1 ' CAUTION...FUEL FRACTIONS SUM TO ', SUMF
2637 ELSE IF (KEYWRD .EQ. 'CNTN') THEN 2702 IF (ABS(SUMO-1.0) .GT. 1.E-6) WRITE (LOUT, *)
2638 LCNTUE = .TRUE. 2703 1 ' CAUTION...OXIDIZER FRACTIONS SUM TO ', SUMO
2639 C 2704 IF (ABS(SUMP-1.0) .GT. 1.E-6) WRITE (LOUT, *)
2640 C NUMBER OF MESH POINTS IN THE REGRID 2705 1 ' CAUTION...PRODUCT FRACTIONS SUM TO ', SUMP
2641 C 2706 C
2642 ELSE IF (KEYWRD .EQ. 'JJRG') THEN 2707 C CHECK FOR NECESSARY INPUT
2643 CALL CKXNUM (LINE, 1, LOUT, NVAL, VALUE, IERR) 2708 C
2644 KERR = KERR.OR.IERR 2709 IF (.NOT. NEC(1)) THEN
2645 JJREGD = INT(VALUE(1)) 2710 WRITE (LOUT, *) ' ERROR..."XEND" NOT SPECIFIED'
2646 LREGRD = .TRUE. 2711 STOP
2647 C 2712 ENDIF
2648 C PERCENTAGE OF REGRID POINTS DEDICATED TO ADAPTION 2713 C
2649 C 2714 IF (.NOT. NEC(2) ) THEN
2650 ELSE IF (KEYWRD .EQ. 'PCAD') THEN 2715 WRITE (LOUT, *) ' ERROR..."TFUEL" NOT GIVEN'
2651 CALL CKXNUM (LINE, 1, LOUT, NVAL, PCTADP, IERR) 2716 STOP
2652 KERR = KERR.OR.IERR 2717 ENDIF
2653 C 2718 IF (.NOT. NEC(3) ) THEN
2654 C RATIO OF GRADIENT REGRID POINTS TO CURVATURE POINTS 2719 WRITE (LOUT, *) ' ERROR..."TOXID" NOT GIVEN'
2655 C 2720 STOP
2656 ELSE IF (KEYWRD .EQ. 'RGTC') THEN 2721 ENDIF
2657 CALL CKXNUM (LINE, 1, LOUT, NVAL, RATGTC, IERR) 2722 C
2658 KERR = KERR.OR.IERR 2723 IF (.NOT. NEC(4) ) THEN
2659 C 2724 WRITE (LOUT, *) ' ERROR..."VFUEL" NOT GIVEN'
2660 C LAST CARD 2725 STOP
2661 C 2726 ENDIF
2662 ELSE IF (KEYWRD(1:3) .EQ. 'END') THEN 2727 IF (.NOT. NEC(5) ) THEN
2663 GO TO 6000 2728 WRITE (LOUT, *) ' ERROR..."VOXID" NOT GIVEN'
2664 ELSE 2729 STOP
2665 C 2730 ENDIF

2731 C 2796 C
2732 C MAKE SURE THE INITIAL GRID POINTS ARE IN ORDER 2797 C THIS SUBROUTINE USES BISECTION TO LINEARLY INTERPOLATE
2733 C 2798 C AN ARRAY OF XX,TT PAIRS. GIVEN AN XX,TT PAIR THIS ROUTINE
2734 IF ((.NOT. CNTNUD) .AND. (.NOT. LUMESH)) THEN 2799 C RETURNS THE INTERPOLATED VALUE OF THE T AT THE POINT X.
2735 NPTS = NP 2800 C
2736 DO 5550 N = 2, NPTS 2801 C INPUT-
2737 IF (X(N-1) .GE. X(N)) THEN 2802 C NPTS - NUMBER OF XX,TT PAIRS.
2738 WRITE (LOUT, *) 2803 C X - LOCATION AT WHICH INTERPOLATED T IS DESIRED.
2739 1 ' ERROR...INITIAL GRID IS OUT OF ORDER' 2804 C XX - ARRAY OF X POINTS AT WHICH TT ARE GIVEN.
2740 STOP 2805 C TT - ARRAY OF T VALUES AT THE XX LOCATIONS.
2741 ENDIF 2806 C
2742 5550 CONTINUE 2807 C OUTPUT-
2743 ENDIF 2808 C T - INTERPOLATED T AT POINT X
2744 C 2809 C
2745 IF (NTEMP.GT.0) THEN 2810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2746 C 2811 C
2747 C MAKE SURE THE (X,T) PAIRS ARE IN ORDER 2812 C check for x outside (1,npts)
2748 C 2813 C
2749 DO 5500 N = 2, NTEMP 2814 IF (X .LE. XX(2)) THEN
2750 IF (XX(N-1) .GE. XX(N)) THEN 2815 N = 2
2751 WRITE (LOUT, *) 2816 S = (TT(N) - TT(N-1)) / (XX(N) - XX(N-1))
2752 1 ' ERROR...SPECIFIED TEMPERATURES ARE OUT OF ORDER' 2817 ELSEIF (X .GE. XX(NPTS-1)) THEN
2753 STOP 2818 N = NPTS-1
2754 ENDIF 2819 S = (TT(N+1) - TT(N)) / (XX(N+1) - XX(N))
2755 5500 CONTINUE 2820 ELSE
2756 C 2821 NLO = 1
2757 C MAKE SURE THE GIVEN TEMPERATURES SPAN THE XEND-XSTR DOMAIN 2822 NHI = NPTS
2758 C 2823 S = 0.0
2759 IF (.NOT.LRSTRT .OR. .NOT.CNTNUD .OR. LUSTGV) THEN 2824 C
2760 IF (XX(1).GT.0.0 .OR. XX(NTEMP).LT.XEND) THEN 2825 C bisect interval
2761 WRITE (LOUT, *) 2826 C
2762 1 ' ERROR...GIVEN TEMPERATURE PROFILE DOES NOT SPAN XEND-XSTR' 2827 50 CONTINUE
2763 STOP 2828 N = (NLO+NHI)/2
2764 ENDIF 2829 IF (X .LT. XX(N)) THEN
2765 ENDIF 2830 IF (X .LT. XX(N-1)) THEN
2766 ENDIF 2831 NHI = N
2767 C 2832 GO TO 50
2768 C SET OPTIONAL INPUT IF NEEDED 2833 ELSEIF (X .EQ. XX(N-1)) THEN
2769 C 2834 N = N-1
2770 IF (.NOT. NOPT(1)) WMIX = (XEND-0.0)*0.50 2835 ELSE
2771 C 2836 S = (TT(N) - TT(N-1)) / (XX(N) - XX(N-1))
2772 IF (.NOT. NOPT(2)) XCEN = (XEND-0.0)*0.35 2837 ENDIF
2773 C 2838 ELSEIF (X .GT. XX(N)) THEN
2774 C formats 2839 IF (X .GT. XX(N+1)) THEN
2775 C 2840 NLO = N
2776 RETURN 2841 GO TO 50
2777 7000 FORMAT(A4, A) 2842 ELSEIF (X .EQ. XX(N+1)) THEN
2778 8000 FORMAT(10X, A4, A76) 2843 N = N + 1
2779 END 2844 ELSE
2780 C 2845 S = (TT(N+1) - TT(N)) / (XX(N+1) - XX(N))
2781 C---------------------------------------------------------------------- 2846 ENDIF
2782 C 2847 ENDIF
2783 SUBROUTINE TEMP(NPTS, X, XX, TT, T) 2848 ENDIF
2784 C 2849 C
2785 C*****precision > double 2850 100 CONTINUE
2786 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 2851 T = TT(N) + S * (X - XX(N))
2787 C*****END precision > double 2852 RETURN
2788 C 2853 END
2789 C*****precision > single 2854 C
2790 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 2855 C--------------------------------------------------------------------
2791 C*****END precision > single 2856 C
2792 C 2857 SUBROUTINE REASEN (II,KK,JJ,NATJ,LDA,LENRGY,LRADI,LNARR,LMULTI,
2793 DIMENSION XX(*), TT(*) 2858 1 LTDIF, LSAVE, LOUT, LVARMC, LTIME, PR,
2794 C 2859 2 WT, YOXID, YFUEL, DT, NTEMP,
2795 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 2860 3 XGIVEN, TGIVEN, X, SN, S, WNDFAC, ABS, REL,
2861 4 SCRCHK, YV, VISC, COND, D, DKJ, TDR, ICKWRK, 2926 C CALL SGBFA (A, LDA, NATJ*JJ, ML, MU, IP, INFO)
2862 5 RCKWRK, IMCWRK, RMCWRK, F, FN, A, DS, SSAVE, 2927 C*****END precision > single
2863 6 IP, RFAC) 2928 C
2864 C 2929 IF (INFO .NE. 0) THEN
2865 C*****precision > double 2930 WRITE(LOUT,*) 'ERROR IN FACTORING THE JACOBIAN, INFO = ',INFO
2866 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 2931 STOP
2867 C*****END precision > double 2932 ENDIF
2868 C 2933 C
2869 C*****precision > single 2934 WRITE (LSAVE) ISENSI
2870 C IMPLICIT REAL (A-H, O-Z), INTEGER (I-N) 2935 C
2871 C*****END precision > single 2936 C COMPUTE THE RAW SENSITIVITY COEFFICIENTS WITH RESPECT TO
2872 C 2937 C THE RATE CONSTANTS, D(MASS FRACTION)/D(RATE CONSTANT).
2873 DIMENSION WT(*), YOXID(*), YFUEL(*), XGIVEN(*), TGIVEN(*), X(*), 2938 C
2874 1 SN(NATJ,*), S(NATJ, *), F(NATJ,*), FN(NATJ,*), 2939 DO 1000 I = 1, II
2875 2 SCRCHK(KK,*), YV(KK,*), VISC(*), COND(*), D(KK,*), 2940 C
2876 3 TDR(KK,*), DKJ(KK,KK,*), DS(*), SSAVE(*), IP(*), 2941 CALL CKRDEX (I, RCKWRK, SAVEP)
2877 4 ICKWRK(*), RCKWRK(*), IMCWRK(*), RMCWRK(*), A(LDA, *) 2942 DP = REL*SAVEP + ABS
2878 C 2943 CALL CKRDEX (-I, RCKWRK, SAVEP+DP)
2879 COMMON /LOCS/ NT, NG, NF, NH, NYS, NY 2944 C
2880 C 2945 CALL FUN (KK,JJ,NATJ,LENRGY,LRADI,LNARR,LMULTI,LTDIF, LVARMC,
2881 LOGICAL LENRGY, LRADI,LNARR,LMULTI, LTDIF, LVARMC, LTIME 2946 1 LTIME,PR,WT,YOXID, YFUEL, DT,NTEMP,XGIVEN,TGIVEN,
2882 C 2947 2 X, SN, S, WNDFAC, SCRCHK(1,1), SCRCHK(1,5), YV,
2883 CHARACTER*18 ISENSI 2948 3 SCRCHK(1,2), SCRCHK(1,3), SCRCHK(1,4),
2884 DATA ISENSI /'SENSITIVITY '/ 2949 4 TFUEL, TOXID, VFUEL, VOXID, AFUEL, AOXID,
2885 C 2950 4 VISC, COND, D, DKJ,
2886 C*****precision > single 2951 5 TDR, ICKWRK, RCKWRK, IMCWRK, RMCWRK, F, RFAC)
2887 C DATA ONE/1.0E0/ 2952 C
2888 C*****END precision > single 2953 CALL CKRDEX (-I, RCKWRK, SAVEP)
2889 C*****precision > double 2954 C
2890 DATA ONE/1.0D0/ 2955 DO 100 J = 1, JJ
2891 C*****END precision > double 2956 DO 100 N = 1, NATJ
2892 2957 SN(N,J) = - (F(N,J)-FN(N,J)) / DP
2893 LTIME = .FALSE. 2958 100 CONTINUE
2894 LVARMC = .TRUE. 2959 C
2895 ML = 2*NATJ - 1 2960 C
2896 MU = 2*NATJ - 1 2961 C*****precision > double
2897 C 2962 CALL DGBSL (A, LDA, NATJ*JJ, ML, MU, IP, SN, 0)
2898 C FORM THE JACOBIAN, AND AT THE SAME TIME EVALUATE THE 2963 C*****END precision > double
2899 C UNPERTURBED FUNCTION FN 2964 C
2900 C 2965 C*****precision > single
2901 CALL JACOB (KK, JJ, NATJ,LENRGY ,LRADI,LNARR, LMULTI,LTDIF,LTIME, 2966 C CALL SGBSL (A, LDA, NATJ*JJ, ML, MU, IP, SN, 0)
2902 1 PR, WT, YOXID, YFUEL, DT, NTEMP, XGIVEN, TGIVEN, 2967 C*****END precision > single
2903 2 X, SN, S, WNDFAC, ABS, REL, SCRCHK, YV, 2968 C
2904 3 TFUEL, TOXID, VFUEL, VOXID, AFUEL, AOXID, 2969 C
2905 3 VISC, COND, D, DKJ, 2970 C SN(N,J) NOW CONTAINS THE RAW SENSIVITY MATRIX DS(N,J)/DAi
2906 4 TDR, ICKWRK, RCKWRK, IMCWRK, RMCWRK, F, FN, A, DS, 2971 C
2907 5 SSAVE, RFAC) 2972 C
2908 2973 C NORMALIZE THE SENSIVITY COEFFICIENTS
2909 ! SUBROUTINE JACOB(KK,POINTS,COMPS,LENRGY,LRADI,LNARR,LMULTI,LTDIF, 2974 C
2910 ! 1 LTIME, PR, WT, YOXID, YFUEL, DT, 2975 DO 200 J = 1, JJ
2911 ! 2 NTEMP, XGIVEN, TGIVEN, MESH, SN, X0, WNDFAC, 2976 SN(NT,J) = SN(NT,J) * MAX(ONE,SAVEP) / S(NT,J)
2912 ! 3 ABSOL, RELAT, SCRTCH, YV, 2977 200 CONTINUE
2913 ! 4 TFUEL, TOXID, VFUEL, VOXID, AFUEL, AOXID, 2978 C
2914 ! 4 VISC, COND, D, DKJ, 2979 DO 500 J = 1, JJ
2915 ! 5 TDR, ICKWRK, RCKWRK, IMCWRK, RMCWRK, Y1, Y0, 2980 SUM = 0.E0
2916 ! 6 A, PERTRB, SAVE, RFAC) 2981 DO 300 L = 1, KK
2917 ! 2982 SUM = SUM + SN(NYS+L,J) / WT(L)
2918 C 2983 300 CONTINUE
2919 C FACTOR THE JACOBIAN 2984 CALL CKMMWY (S(NY,J), ICKWRK, RCKWRK, WTM)
2920 C 2985 DO 400 K = 1, KK
2921 C*****precision > double 2986 SN(NYS+K,J) = SN(NYS+K,J) *
2922 CALL DGBFA (A, LDA, NATJ*JJ, ML, MU, IP, INFO) 2987 1 MAX(ONE,SAVEP) / S(NYS+K,J)
2923 C*****END precision > double 2988 2 - MAX(ONE,SAVEP) * WTM * SUM
2924 C 2989 400 CONTINUE
2925 C*****precision > single 2990 500 CONTINUE

2991 C 3056 C
2992 WRITE (LSAVE) I, ((SN(N,J),N=1,NATJ), J=1,JJ) 3057 GASEMI = GASEMI * PRESS/1013250
2993 C 3058 C
2994 1000 CONTINUE 3059 ELSE
2995 C 3060 GASEMI = 0.50
2996 RETURN 3061 ENDIF
2997 END 3062 C
2998 3063 C WRITE (*,8101) PCO,PCH4,PCO2,PH2O
2999 C 3064 C8101 format (1x,'PCO=',f7.3,' PCH4=',f7.3
3000 C------------------------------------------------------------------------------------ 3065 C 1 ,' PCO2=',f7.3,' PH2O=',f7.3)
3001 SUBROUTINE RADEMIS(KK,ICKWRK, RCKWRK,PRESS,TEMP,MASSF,POLYCO, 3066 C
3002 1 GASNUM,NGAS,GASEMI) 3067 C WRITE (*,8102) MOLEF(GASNUM(1)),MOLEF(GASNUM(2)),
3003 C Parameters Illustration: 3068 C 1 MOLEF(GASNUM(3)),MOLEF(GASNUM(4))
3004 C 3069 C8102 format (1x,'XCO=',f8.3,' XCH4=',f8.3
3005 C PR: Pressure (Double) 3070 C 1 ,' XCO2=',f8.3,' XH2O=',f8.3)
3006 C TEMP: Temperature (Double) 3071 C
3007 C MASSF: Double Array of Species Mass Fractions 3072 C WRITE (*,8100) GASEMI
3008 C Must be at leaet KK of Dimension 3073 C8100 format (1x,'GASEMI=',f10.4)
3009 C POLYCO: A 4*7 Double Array, Polymial Coefficients 3074 C
3010 C GASNUM: Index of Radiative Gases in Species List 3075 C WRITE (*,8107) TEMP1
3011 C Integer array that has Dimension of NGAS 3076 C8107 format (1x,'TEMP1=',f10.4)
3012 C NGAS: Number of radiative gases 3077 C
3013 C GASEMI: OUTPUT---The Mixture Emissivity 3078 RETURN
3014 IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 3079 C
3015 C 3080 END
3016 DOUBLE PRECISION MASSF(*), MOLEF(KK) 3081 C
3017 INTEGER GASNUM(*) 3082 C
3018 DIMENSION POLYCO(7,4) 3083
3019 C 3084 C**************************************************************************
3020 C 3085
3021 CALL CKYTX(MASSF,ICKWRK, RCKWRK,MOLEF) 3086 C
3022 C 3087
3023 C 3088 CCC SUBROUTINE RADCAL
3024 TEMP1 = (TEMP/1000)*9/5 3089 CCC
3025 IF( (TEMP1 .GE. 0.0) .AND. (TEMP1 .LE. 10.0)) THEN 3090 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
3026 C 3091 CCC
3027 C 3092 CCC real :: ommin
3028 PCO=0.0 3093 CCC real :: ommax
3029 DO 1996 I=1,7 3094 CCC
3030 PCO = PCO + POLYCO(I,1)*TEMP1**(I-1) 3095 CCC
3031 1996 CONTINUE 3096 CCC DOUBLE PRECISION SDWEAK,GDINV,GDDINV,XC,AOM,Q,QW(600),TTAU(600),
3032 3097 CCC
3033 C 3098 CCC 2 XTOT(100),XT(600),XSTAR(100),X(4,100),UK,TAU(100)
3034 PCH4=0.0 3099 CCC
3035 DO 1997 I=1,7 3100 CCC COMMON/CMAIN/OMMIN,OMMAX,NOM,TWALL,P(6,100),SPECIE(5),NPRINT
3036 PCH4 = PCH4 + POLYCO(I,2)*TEMP1**(I-1) 3101 CCC
3037 1997 CONTINUE 3102 CCC COMMON/CPARAM/GAMMA(4,7)
3038 C 3103 CCC
3039 3104 CCC COMMON/CPART/W(100),XPART(100),T(100),DD(100),NPT
3040 PCO2=0.0 3105 CCC
3041 DO 1998 I=1,7 3106 CCC COMMON/CLAYER/ QL(100),QLS(100,600)
3042 PCO2 = PCO2 + POLYCO(I,3)*TEMP1**(I-1) 3107 CCC
3043 1998 CONTINUE 3108 CCC DIMENSION U(4,100),AC(100),AD(100),GC(4,100),AMBDA(600),TAUS(100),
3044 C 3109 CCC
3045 3110 CCC 2 AB(600),PKPA(6)
3046 PH2O=0.0 3111 CCC
3047 DO 1999 I=1,7 3112 CCC COMMON/RCDATA/NOL,XLL(100),TL(100),RSC(7,100),WALLT,WAVMAX,WAVMIN
3048 PH2O = PH2O + POLYCO(I,4)*TEMP1**(I-1) 3113 CCC
3049 1999 CONTINUE 3114 CCCC
3050 C 3115 CCCC [NOTE: THE TOTAL INTENSITY CALCULATED IS THAT WHICH LEAVES INTERVAL J=1.
3051 3116 CCCC P(I,J) IS PARTIAL PRESSURE, ATM, OF SPECIES I IN INTERVAL J.
3052 GASEMI = PCO*MOLEF(GASNUM(1))+ 3117 CCCC I=1,2,3,4,5, OR 6 IMPLIES SPECIES IS CO2, H2O, CH4, CO, O2, OR N2, RESP.]
3053 1 PCH4*MOLEF(GASNUM(2))+ 3118 CCCC
3054 2 PCO2*MOLEF(GASNUM(3))+ 3119 CCCC OPEN (7,FILE='RC.DAT')
3055 3 PH2O*MOLEF(GASNUM(4)) 3120 CCCC READ(7,*)NPT
3121 CCC 3186 CCCC REPLACE THE PREVIOUS WITH THE FOLLOWING
3122 CCC NPT = NOL 3187 CCC
3123 CCC 3188 CCC NOM=IFIX((OMMAX-OMMIN)/600.)
3124 CCCC IF(NPT.EQ.0)GO TO 3000 3189 CCC
3125 CCC 3190 CCC GO TO 9906
3126 CCC SPECIE(1)=0. 3191 CCC
3127 CCC SPECIE(2)=0. 3192 CCC9901 NOM=IFIX((OMMAX-OMMIN)/5.)
3128 CCC SPECIE(3)=0. 3193 CCC
3129 CCC SPECIE(4)=0. 3194 CCC GO TO 9906
3130 CCC SPECIE(5)=0. 3195 CCC
3131 CCC 3196 CCC9902 NOM=IFIX((OMMAX-OMMIN)/50.)
3132 CCC DO 9950 J=1,NPT 3197 CCC
3133 CCC 3198 CCC GO TO 9906
3134 CCCC READ(7,*)DD(J),T(J),(P(I,J),I=1,6),W(J) 3199 CCC
3135 CCC 3200 CCC9903 NOM=IFIX((1100.-OMMIN)/5.)+IFIX((5000.-1100.)/25.)
3136 CCC DD(J) = XLL(J) 3201 CCC
3137 CCC 3202 CCC 2 +IFIX((OMMAX-5000.)/50.)
3138 CCC T(J) = TL(J) 3203 CCC
3139 CCC 3204 CCC GO TO 9906
3140 CCC DO 9949 I=1,6 3205 CCC
3141 CCC 3206 CCC9904 NOM=IFIX((1100.-OMMIN)/5.)+IFIX((OMMAX-1100.)/25.)
3142 CCC P(I,J) = RSC(I,J) 3207 CCC
3143 CCC 3208 CCC GO TO 9906
3144 CCC9949 CONTINUE 3209 CCC
3145 CCC 3210 CCC9905 NOM=IFIX((5000.-OMMIN)/25.)+IFIX((OMMAX-5000.)/50.)
3146 CCC W(J) = RSC(7,J) 3211 CCC
3147 CCC 3212 CCC9906 NPRINT=1
3148 CCC DO 9948 I=1,6 3213 CCC
3149 CCC 3214 CCCC
3150 CCC9948 P(I,J)=P(I,J)/101. 3215 CCC DOM=5.0
3151 CCC 3216 CCC
3152 CCC SPECIE(1)=P(1,J)+SPECIE(1) 3217 CCC OMEGA=OMMIN-DOM
3153 CCC 3218 CCC
3154 CCC SPECIE(2)=P(2,J)+SPECIE(2) 3219 CCC NM=NOM-1
3155 CCC 3220 CCC
3156 CCC SPECIE(3)=P(3,J)+SPECIE(3) 3221 CCCC WRITE (*,2999) NOM,OMMIN,OMMAX
3157 CCC 3222 CCC
3158 CCC SPECIE(4)=P(4,J)+SPECIE(4) 3223 CCCC2999 FORMAT ('NOM=',I5,'OMMIN=',I5,'OMMAX=',I10)
3159 CCC 3224 CCCC
3160 CCC SPECIE(5)=W(J)+SPECIE(5) 3225 CCC
3161 CCC 3226 CCCC LOOP 1000 COMPUTES EACH SPECTRAL CONTRIBUTION
3162 CCC9950 CONTINUE 3227 CCC
3163 CCC 3228 CCCC *********************************************
3164 CCCC READ(7,*)TWALL,OMMIN,OMMAX 3229 CCC
3165 CCC TWALL = WALLT 3230 CCC
3166 CCC 3231 CCC
3167 CCC OMMIN = WAVMIN 3232 CCC DO 1000 KK=1,NOM
3168 CCC 3233 CCC
3169 CCC OMMAX = WAVMAX 3234 CCC OMEGA=OMEGA+DOM
3170 CCC 3235 CCC
3171 CCCC CLOSE(7) 3236 CCC IF(OMEGA.LE.1100.)GO TO 109
3172 CCCC THESE STATEMENTS ARE COMMENTED OUT. GET A FINE WAVELENGTH INCREMENT 3237 CCC
3173 CCC 3238 CCC OMEGA=OMEGA+20.
3174 CCC IF(OMMAX.LT.1100.)GO TO 9901 3239 CCC
3175 CCC 3240 CCC IF(OMEGA.LE.5000.)GO TO 109
3176 CCC IF(OMMIN.GT.5000.)GO TO 9902 3241 CCC
3177 CCC 3242 CCC OMEGA=OMEGA+25.
3178 CCC IF(OMMIN.LT.1100..AND.OMMAX.GT.5000.)GO TO 9903 3243 CCC
3179 CCC 3244 CCC109 AMBDA(KK)=10000./OMEGA
3180 CCC IF(OMMIN.LT.1100.)GO TO 9904 3245 CCC
3181 CCC 3246 CCC ABGAS=0.
3182 CCC IF(OMMAX.GT.5000.)GO TO 9905 3247 CCC
3183 CCC 3248 CCCC
3184 CCC NOM=IFIX((OMMAX-OMMIN)/25.) 3249 CCC
3185 CCC 3250 CCCC LOOP 200 COMPUTES THE CONTRIBUTION OF EACH SPECIES TO TAU

3251 CCC 3316 CCC102 CALL H2O(OMEGA,TEMP,GC(2,J),SDWEAK,GDINV,GDDINV)

3252 CCCC ********************************************************* 3317 CCC
3253 CCC 3318 CCC GO TO 108
3254 CCC DO 200 I=1,4 3319 CCC
3255 CCC 3320 CCC103 CONTINUE
3256 CCCC IF SPECIE(I) IS SET TO 0., THAT PARTICULAR RADIATING SPECIES IS 3321 CCC
3257 CCC 3322 CCC CALL FUEL(OMEGA,TEMP,P(3,J),PTOT,GC(3,J),SDWEAK,GDINV,GDDINV)
3258 CCCC NOT PRESENT. THE SPECIES CONSIDERED ARE 3323 CCC
3259 CCC 3324 CCC GO TO 108
3260 CCCC I SPECIES 3325 CCC
3261 CCC 3326 CCC104 CONTINUE
3262 CCCC 1 CO2 3327 CCC
3263 CCC 3328 CCC CALL CO(OMEGA,TEMP,GC(4,J),SDWEAK,GDINV,GDDINV)
3264 CCCC 2 H2O 3329 CCC
3265 CCC 3330 CCC108 UK=SDWEAK*U(I,J)
3266 CCCC 3 CH4 3331 CCC
3267 CCC 3332 CCC IF(J.EQ.1) GO TO 110
3268 CCCC 4 CO 3333 CCC
3269 CCC 3334 CCC GKD=UK*GDINV
3270 CCCC 5 PARTICULATES 3335 CCC
3271 CCC 3336 CCC GKDD=UK*GDDINV
3272 CCC 3337 CCC
3273 CCC IF(SPECIE(I).EQ.0.) GO TO 200 3338 CCC XSTAR(J)=XSTAR(J-1)+UK
3274 CCC 3339 CCC
3275 CCCC 3340 CCC AD(J)=(XSTAR(J-1)*AD(J-1)+GKDD)/XSTAR(J)
3276 CCC 3341 CCC
3277 CCCC LOOP 100 IS FOR EACH ELEMENT ALONG PATH 3342 CCC AC(J)=(XSTAR(J-1)*AC(J-1)+GKD)/XSTAR(J)
3278 CCC 3343 CCC
3279 CCCC *************************************** 3344 CCC GO TO 115
3280 CCC 3345 CCC
3281 CCC DO 100 J=1,NPT 3346 CCC110 XSTAR(1)=UK+1.D-34
3282 CCC 3347 CCC
3283 CCCC (CALCULATION PROCEEDS IN ACCORDANCE WITH THE SLG MODEL, TABLE 5-18 3348 CCC ABGAS=UK/DD(1)+ABGAS
3284 CCC 3349 CCC
3285 CCCC IN NASA SP-3080.) 3350 CCC AD(1)=GDDINV
3286 CCC 3351 CCC
3287 CCC 3352 CCC AC(1)=GDINV
3288 CCC IF(KK.GT.1) GO TO 107 3353 CCC
3289 CCC 3354 CCC115 IF(XSTAR(J).LT.1.E-6) GO TO 125
3290 CCC U(I,J)=273./T(J)*P(I,J)*100.*DD(J) 3355 CCC
3291 CCC 3356 CCC XD=1.7*AD(J)*(DLOG(1.+(XSTAR(J)/1.7/AD(J))**2))**.5
3292 CCC GC(I,J)=0. 3357 CCC
3293 CCC 3358 CCC YD=1.-(XD/XSTAR(J))**2
3294 CCC PTOT=0. 3359 CCC
3295 CCC 3360 CCC XC=XSTAR(J)/(1.+XSTAR(J)/4./AC(J))**.5
3296 CCC DO 105 II=1,6 3361 CCC
3297 CCC 3362 CCCC
3298 CCC PTOT=P(II,J)+PTOT 3363 CCC
3299 CCC 3364 CCCC THE FOLLOWING LOOP COMPUTES THE OPTICAL THICKNESS, XC, FOR METHANE USING
3300 CCC105 GC(I,J)=GC(I,J)+GAMMA(I,II)*P(II,J)*(273./T(J))**.5 3365 CCC
3301 CCC 3366 CCCC THE GODSON EQUATION AND AN APPROXIMATION TO THE LADENBERG-REICHE
3302 CCC GC(I,J)=GC(I,J)+GAMMA(I,7)*P(I,J)*273./T(J) 3367 CCC
3303 CCC 3368 CCCC FUNCTION AS RECOMMENDED BY BROSMER AND TIEN (JQSRT 33,P 521). THE
3304 CCC107 IF(P(I,J).EQ.0.) GO TO 121 3369 CCC
3305 CCC 3370 CCCC ERROR FUNCTION IS FOUND FROM ITS SERIES EXPANSION.
3306 CCC TEMP=T(J) 3371 CCC
3307 CCC 3372 CCCC
3308 CCC GO TO(101,102,103,104),I 3373 CCC
3309 CCC 3374 CCC IF(I.NE.3.) GO TO 118
3310 CCC 3375 CCC
3311 CCC101 CALL CO2(OMEGA,TEMP,GC(1,J),SDWEAK,GDINV,GDDINV) 3376 CCC IF(XC.GT.10.)GO TO 118
3312 CCC 3377 CCC
3313 CCC 3378 CCC AOM=XC
3314 CCC GO TO 108 3379 CCC
3315 CCC 3380 CCC XX=.5*3.141593**.5*XC
3381 CCC 3446 CCCC
3382 CCC IF(XX.LE.3.)GO TO 111 3447 CCC
3383 CCC 3448 CCCC DETERMINE OPTICAL DEPTH OF SOOT
3384 CCC AOM=1.-EXP(-XX**2)/(3.141593**.5*XX) 3449 CCC
3385 CCC 3450 CCCC
3386 CCC GO TO 117 3451 CCC
3387 CCC 3452 CCC IF(SPECIE(5).EQ.0.) GO TO 250
3388 CCC111 ENN=1. 3453 CCC
3389 CCC 3454 CCC CALL POD(OMEGA)
3390 CCC DO 116 N=1,30 3455 CCC
3391 CCC 3456 CCC GO TO 260
3392 CCC ENN=ENN*N 3457 CCC
3393 CCC 3458 CCC250 DO 255 J=1,NPT
3394 CCC MM=2*N+1 3459 CCC
3395 CCC 3460 CCC255 XPART(J)=0.
3396 CCC ARG=1.128379*(-1.)**N*((.88622693*XC)**MM)/(MM*ENN) 3461 CCC
3397 CCC 3462 CCC260 CONTINUE
3398 CCC ARGNEW=ARG+AOM 3463 CCC
3399 CCC 3464 CCC AB(KK)=ABGAS+XPART(1)/DD(1)
3400 CCCC IF(ABS(ARG/ARGNEW).LT..000001)N=30 3465 CCC
3401 CCC 3466 CCCC
3402 CCC116 AOM=ARGNEW 3467 CCC
3403 CCC 3468 CCCC EVALUATE THE COMBINED SPECTRAL TRANSMITTANCE AND RADIANCE
3404 CCC117 IF(AOM.GE.1.)AOM=.9999999 3469 CCC
3405 CCC 3470 CCCC *********************************************************
3406 CCC XC=-DLOG(1.-AOM) 3471 CCC
3407 CCC 3472 CCC DO 500 J=1,NPT
3408 CCCC 3473 CCC
3409 CCC 3474 CCC XTOT(J)=0.
3410 CCCC 3475 CCC
3411 CCC 3476 CCC DO 300 I=1,4
3412 CCC118 YC=1.-(XC/XSTAR(J))**2 3477 CCC
3413 CCC 3478 CCC IF(SPECIE(I).EQ.0.) X(I,J)=0.
3414 CCC Y=1./YC**2+1./YD**2-1. 3479 CCC
3415 CCC 3480 CCC300 XTOT(J)=X(I,J)+XTOT(J)
3416 CCC X(I,J)=XSTAR(J)*((1.-(Y**(-.5)))**.5) 3481 CCC
3417 CCC 3482 CCC XTOT(J)=XTOT(J)+XPART(J)
3418 CCC GO TO 100 3483 CCC
3419 CCC 3484 CCC IF(XTOT(J).GE.99.) GO TO 305
3420 CCC121 IF(J.GT.1) GO TO 123 3485 CCC
3421 CCC 3486 CCC TAU(J)=DEXP(-XTOT(J))
3422 CCC XSTAR(1)=1.D-34 3487 CCC
3423 CCC 3488 CCC GO TO 310
3424 CCC AC(1)=1. 3489 CCC
3425 CCC 3490 CCC305 TAU(J)=0.
3426 CCC AD(1)=1. 3491 CCC
3427 CCC 3492 CCC310 IF(J.EQ.1) GO TO 510
3428 CCC GO TO 125 3493 CCC
3429 CCC 3494 CCC QLS(J,KK)=-(TAU(J)-TAU(J-1))*PLANCK(T(J),AMBDA(KK))
3430 CCC123 XSTAR(J)=XSTAR(J-1) 3495 CCC
3431 CCC 3496 CCC QW(KK)=QW(KK)+QLS(J,KK)
3432 CCC AC(J)=AC(J-1) 3497 CCC
3433 CCC 3498 CCC GO TO 500
3434 CCC AD(J)=AD(J-1) 3499 CCC
3435 CCC 3500 CCC510 QW(KK)=-(TAU(1)-1.)*PLANCK(T(1),AMBDA(KK))
3436 CCC125 X(I,J)=XSTAR(J) 3501 CCC
3437 CCC 3502 CCC QLS(1,KK)=QW(KK)
3438 CCC100 CONTINUE 3503 CCC
3439 CCC 3504 CCC500 CONTINUE
3440 CCCC 3505 CCC
3441 CCC 3506 CCC XT(KK)=XTOT(NPT)
3442 CCCC 3507 CCC
3443 CCC 3508 CCC TTAU(KK)=TAU(NPT)
3444 CCC200 CONTINUE 3509 CCC
3445 CCC 3510 CCC QW(KK)=QW(KK)+TTAU(KK)*PLANCK(TWALL,AMBDA(KK))

3511 CCC 3576 CCC

3512 CCC1000 CONTINUE 3577 CCC GO TO 1012
3513 CCC 3578 CCC
3514 CCCC 3579 CCC1010 TAUS(J)=0.
3515 CCC 3580 CCC
3516 CCCC INTEGRATE THE RADIANCE OVER THE SPECTRUM 3581 CCC1012 IF(J.EQ.1)GO TO 1021
3517 CCC 3582 CCC
3518 CCCC 3583 CCC RSL=RSL-(TAUS(J)-TAUS(J-1))*PLANCK(T(J),WL)*DAMBDA
3519 CCC 3584 CCC
3520 CCC Q=QW(1)*(AMBDA(1)-AMBDA(2)) 3585 CCC GO TO 1020
3521 CCC 3586 CCC
3522 CCC DO 1100 KK=2,NM 3587 CCC1021 RSL=RSL-(TAUS(1)-1.)*PLANCK(T(1),WL)*DAMBDA
3523 CCC 3588 CCC
3524 CCC1100 Q=Q+QW(KK)*(AMBDA(KK-1)-AMBDA(KK+1))/2. 3589 CCC ABLONG=ABLONG+XPART(1)/DD(1)*PLANCK(T(1),WL)*DAMBDA*5.5411E7
3525 CCC 3590 CCC
3526 CCC Q=Q+QW(NOM)*(AMBDA(NOM-1)-AMBDA(NOM)) 3591 CCC 2 /(T(1))**4
3527 CCCC 3592 CCC
3528 CCCC 3593 CCC ABIL=ABIL+XPART(1)/DD(1)*PLANCK(TWALL,WL)*DAMBDA*5.5411E7
3529 CCC DO 1111 J=1,NPT 3594 CCC
3530 CCC 3595 CCC 2 /(TWALL+.000001)**4
3531 CCC QL(J)=QLS(J,1)*(AMBDA(1)-AMBDA(2)) 3596 CCC
3532 CCC 3597 CCC1020 CONTINUE
3533 CCC DO 1110 KK=2,NM 3598 CCC
3534 CCC 3599 CCC RSL=RSL+TAUS(NPT)*PLANCK(TWALL,WL)*DAMBDA
3535 CCC1110 QL(J)=QL(J)+QLS(J,KK)*(AMBDA(KK-1)-AMBDA(KK+1))/2. 3600 CCC
3536 CCC 3601 CCC1040 CONTINUE
3537 CCC QL(J)=QL(J)+QLS(J,NOM)*(AMBDA(NOM-1)-AMBDA(NOM)) 3602 CCC
3538 CCCC 3603 CCC KMIN=OMMAX/100*100
3539 CCC1111 CONTINUE 3604 CCC
3540 CCC 3605 CCC DO 1080 KK=KMIN,25000,100
3541 CCCC DETERMINE SOOT RADIANCE FOR SHORT AND LONG WAVELENGTHS. 3606 CCC
3542 CCC 3607 CCC OMEGA=FLOAT(KK)
3543 CCCC 3608 CCC
3544 CCC 3609 CCC WL=10000./OMEGA
3545 CCC RSL=0. 3610 CCC
3546 CCC 3611 CCC DAMBDA=10000./(OMEGA-50.)-10000./(OMEGA+50.)
3547 CCC RSS=0. 3612 CCC
3548 CCC 3613 CCC CALL POD(OMEGA)
3549 CCC ABLONG=0. 3614 CCC
3550 CCC 3615 CCC DO 1070 J=1,NPT
3551 CCC ABSHRT=0. 3616 CCC
3552 CCC 3617 CCC IF(XPART(J).GE.33.) GO TO 1050
3553 CCC ABIL=0. 3618 CCC
3554 CCC 3619 CCC TAUS(J)=EXP(-XPART(J))
3555 CCC ABIS=0. 3620 CCC
3556 CCC 3621 CCC GO TO 1060
3557 CCC IF(SPECIE(5).EQ.0..AND.TWALL.EQ.0.)GO TO 1090 3622 CCC
3558 CCC 3623 CCC1050 TAUS(J)=0.
3559 CCC KMAX=OMMIN/5*5 3624 CCC
3560 CCC 3625 CCC1060 IF(J.EQ.1)GO TO 1071
3561 CCC DO 1040 KK=5,KMAX,5 3626 CCC
3562 CCC 3627 CCC RSS=RSS-(TAUS(J)-TAUS(J-1))*PLANCK(T(J),WL)*DAMBDA
3563 CCC OMEGA=FLOAT(KK) 3628 CCC
3564 CCC 3629 CCC GO TO 1070
3565 CCC WL=10000./OMEGA 3630 CCC
3566 CCC 3631 CCC1071 RSS=RSS-(TAUS(1)-1.)*PLANCK(T(1),WL)*DAMBDA
3567 CCC DAMBDA=10000./(OMEGA-2.5)-10000./(OMEGA+2.5) 3632 CCC
3568 CCC 3633 CCC ABSHRT=ABSHRT+XPART(1)/DD(1)*PLANCK(T(1),WL)*DAMBDA*5.5411E7
3569 CCC CALL POD(OMEGA) 3634 CCC
3570 CCC 3635 CCC 2 /(T(1))**4
3571 CCC DO 1020 J=1,NPT 3636 CCC
3572 CCC 3637 CCC ABIS=ABIS+XPART(1)/DD(1)*PLANCK(TWALL,WL)*DAMBDA*5.5411E7
3573 CCC IF(XPART(J).GE.33.) GO TO 1010 3638 CCC
3574 CCC 3639 CCC 2 /(TWALL+.000001)**4
3575 CCC TAUS(J)=EXP(-XPART(J)) 3640 CCC
3641 CCC1070 CONTINUE 3706 CCCC WRITE(*,16) APOS,DD(J)*100.,T(J),P(1,J)*101.,P(2,J)*101.,
3642 CCC 3707 CCCC 1 P(3,J)*101.,P(4,J)*101.,QL(J)*3.14159*2/DD(J)
3643 CCC RSS=RSS+TAUS(NPT)*PLANCK(TWALL,WL)*DAMBDA 3708 CCC
3644 CCC 3709 CCC3100 CONTINUE
3645 CCC1080 CONTINUE 3710 CCCC THE FOLLOWING SECTION COMPUTES THE MEAN ABSORPTION COEFFICIENTS
3646 CCC 3711 CCC
3647 CCC1090 CONTINUE 3712 CCCC IF THE SYSTEM IS HOMOGENEOUS (IE., NPT=1).
3648 CCC 3713 CCC
3649 CCC Q=Q+RSS+RSL 3714 CCCC
3650 CCC 3715 CCC
3651 CCCC 8 3716 CCC IF(NPT.NE.1)GO TO 6109
3652 CCC 3717 CCC
3653 CCCC 3718 CCC NM=NOM-1
3654 CCC 3719 CCC
3655 CCC IF(NPRINT.EQ.1) GO TO 2300 3720 CCC AIWALL=AB(1)*(AMBDA(1)-AMBDA(2))/2.*PLANCK(TWALL,AMBDA(1))
3656 CCC 3721 CCC
3657 CCC IF(NPRINT.EQ.0)GO TO 3000 3722 CCC AP0=AB(1)*(AMBDA(1)-AMBDA(2))/2.*PLANCK(T(1),AMBDA(1))
3658 CCC 3723 CCC
3659 CCC GO TO 2400 3724 CCC DO 6100 KK=2,NM
3660 CCC 3725 CCC
3661 CCC2300 CONTINUE 3726 CCC AIWALL=AIWALL+AB(KK)*(AMBDA(KK-1)-AMBDA(KK+1))/2.
3662 CCCC2300 WRITE(*,4) 3727 CCC
3663 CCC 3728 CCC 2 *PLANCK(TWALL,AMBDA(KK))
3664 CCC NPRINT=2 3729 CCC
3665 CCC 3730 CCC AP0=AP0+AB(KK)*(AMBDA(KK-1)-AMBDA(KK+1))/2.
3666 CCC DO 2000 J=1,NPT 3731 CCC
3667 CCC 3732 CCC 2 *PLANCK(T(1),AMBDA(KK))
3668 CCC DO 2001 I=1,6 3733 CCC
3669 CCC 3734 CCC6100 CONTINUE
3670 CCC2001 PKPA(I)=P(I,J)*101. 3735 CCC
3671 CCC 3736 CCC AP0=(AP0+AB(NOM)*(AMBDA(NM)-AMBDA(NOM))/2.
3672 CCC2000 CONTINUE 3737 CCC
3673 CCCC2000 WRITE(*,6)J,DD(J),T(J),(PKPA(I),I=1,6),W(J) 3738 CCC 2 *PLANCK(T(1),AMBDA(NOM)))*5.5411E7/T(1)**4+ABSHRT+ABLONG
3674 CCC 3739 CCC
3675 CCCC WRITE(*,7)TWALL 3740 CCC IF(TWALL.EQ.T(1).OR.TWALL.EQ.0.) GO TO 6105
3676 CCC2400 CONTINUE 3741 CCC
3677 CCCC2400 WRITE(*,8) Q 3742 CCC AIWALL=(AIWALL+AB(NOM)*(AMBDA(NM)-AMBDA(NOM))/2.*
3678 CCC2401 CONTINUE 3743 CCC
3679 CCCC2401 WRITE(*,10) 3744 CCC 2 PLANCK(TWALL,AMBDA(NOM)))*5.5411E7/TWALL**4
3680 CCC 3745 CCC
3681 CCC LMAX=NOM/2 3746 CCC AMEAN=-1./DD(1)*DLOG((5.5411E7*Q-T(1)**4)/(TWALL**4-T(1)**4))
3682 CCC 3747 CCC
3683 CCC IF(LMAX*2.LT.NOM) LMAX=LMAX+1 3748 CCC GO TO 6107
3684 CCC 3749 CCC
3685 CCC DO 2100 L=1,LMAX 3750 CCC6105 AIWALL=AP0
3686 CCC 3751 CCC
3687 CCC K=NOM-LMAX+1-L 3752 CCC AMEAN=-1./DD(1)*DLOG((5.5411E7*Q-T(1)**4)/(-T(1)**4))
3688 CCC 3753 CCC
3689 CCC J=K+LMAX 3754 CCC6107 CONTINUE
3690 CCC 3755 CCCC6107 WRITE(*,14) AMEAN,AP0,AIWALL
3691 CCC IF(K.LT.1) K=1 3756 CCC
3692 CCC 3757 CCCC
3693 CCC2100 CONTINUE 3758 CCC
3694 CCCC2100 WRITE(*,12)AMBDA(J),QW(J),TTAU(J),AMBDA(K),QW(K),TTAU(K) 3759 CCCC
3695 CCC 3760 CCC
3696 CCC3000 CONTINUE 3761 CCC4 FORMAT(/,' Radial Profiles'/
3697 CCC 3762 CCC
3698 CCCC WRITE(*,15) 3763 CCC 1' ---------------'//
3699 CCC 3764 CCC
3700 CCC APOS=0.0 3765 CCC 2' Partial Pressures, kPa'/
3701 CCC 3766 CCC
3702 CCC DO 3100 J=1,NPT 3767 CCC 3' J dist,m temp,K CO2 H2O CH4 CO O2 N2
3703 CCC 3768 CCC
3704 CCC APOS=APOS+DD(J)*100. 3769 CCC 4 FV')
3705 CCC 3770 CCC

3771 CCC6 FORMAT(1X,I2,F9.5,F7.0,6(F8.3),1X,E10.4) 3836 CCC IF(OMEGA.GT.2474.)GO TO 300

3772 CCC 3837 CCC
3773 CCC7 FORMAT('wall',9X,F6.0) 3838 CCC IF(OMEGA.GT.1975.)GO TO 100
3774 CCC 3839 CCC
3775 CCC8 FORMAT(/,' Total directional radiated energy flux =',E12.6, 3840 CCC IF(OMEGA.GT.1100.)GO TO 300
3776 CCC 3841 CCC
3777 CCC 1' Watts/m-2/strad'//' ') 3842 CCC IF(OMEGA.GT.880.)GO TO 600
3778 CCC 3843 CCC
3779 CCC10 FORMAT(8X,'Spectral Intensity Distribution, Watts/m-2/micron/strad 3844 CCC IF(OMEGA.GT.500.)GO TO 400
3780 CCC 3845 CCC
3781 CCC 1',/ 8X,'------------------------------------------------------- 3846 CCC GO TO 300
3782 CCC 3847 CCC
3783 CCC 2',//,2X,'micron',4X,'intensity',6X,'tau',8X,'micron',4X,'intensity 3848 CCCCONTRIBUTION TO 2.0 MICRON BAND FROM (000)-(041),(000)-(121),AND (000)
3784 CCC 3849 CCC
3785 CCC 3',6X,'tau') 3850 CCCC -(201) TRANS.
3786 CCC 3851 CCC
3787 CCC12 FORMAT(2(F8.3,3X,E10.4,2X,F8.4,5X)) 3852 CCC500 OM1=1354.91
3788 CCC 3853 CCC
3789 CCC14 FORMAT(///'The effective absorption coef. is ', E12.6,'/m',/ 3854 CCC OM2=673.0
3790 CCC 3855 CCC
3791 CCC 2 'The Planck-mean absorption coef. is ', E12.6,'/m',/ 3856 CCC OM3=2396.49
3792 CCC 3857 CCC
3793 CCC 3 'The wall-incident mean is ', E12.6,'/m',/////) 3858 CCC BCNT(1)=4860.5
3794 CCC 3859 CCC
3795 CCC15 FORMAT(8X,'X(cm) DD(J) T(J) PCO2 PH2O PCH4 PCO 3860 CCC BCNT(2)=4983.5
3796 CCC 1 VI(W/m-3)') 3861 CCC
3797 CCC16 FORMAT(3X,F10.5,1X,F8.5,1X,F7.2,1X,4(F7.3,1X),E12.3) 3862 CCC BCNT(3)=5109.0
3798 CCCC 3863 CCC
3799 CCC 3864 CCC TO=300.
3800 CCC6109 CONTINUE 3865 CCC
3801 CCC 3866 CCC C2=1.4388
3802 CCC RETURN 3867 CCC
3803 CCC 3868 CCC BE=0.391635
3804 CCC END 3869 CCC
3805 CCC 3870 CCC COM1=4.*OM2+OM3
3806 CCCC 3871 CCC
3807 CCC 3872 CCC COM2=OM1+2.*OM2+OM3
3808 CCCC***************************************************************************** 3873 CCC
3809 CCC 3874 CCC COM3=2.*OM1+OM3
3810 CCCC 3875 CCC
3811 CCC 3876 CCC ATOT(3)=0.426*TO/TEMP*(1.-EXP(-C2*COM3/TEMP/(1.-EXP(-C2*OM1/TEMP))
3812 CCC SUBROUTINE CO2(OMEGA,TEMP,GC1,SDWEAK,GDINV,GDDINV) 3877 CCC
3813 CCC 3878 CCC 1))**2/(1.-EXP(-C2*OM3/TEMP))
3814 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 3879 CCC
3815 CCC 3880 CCC ATOT(2)=1.01*TO/TEMP*(1.-EXP(-C2*COM2/TEMP))/(1.-EXP(-C2*OM1/TEMP)
3816 CCC COMMON/CCO2/SD15(6,80) 3881 CCC
3817 CCC 3882 CCC 1)/(1.-EXP(-C2*OM2/TEMP))**2/(1.-EXP(-C2*OM3/TEMP))
3818 CCC DOUBLE PRECISION AA,BB,CC,DD,EE,FF,GG,SMINUS,SPLUS,SDWEAK,SDSTRG 3883 CCC
3819 CCC 3884 CCC ATOT(1)=0.272*TO/TEMP*(1.-EXP(-C2*COM1/TEMP))/(1.-EXP(-C2*OM2/TEMP
3820 CCC 1,DINV,GDINV,GDDINV 3885 CCC
3821 CCC 3886 CCC 1))**4/(1.-EXP(-C2*OM3/TEMP))
3822 CCC DIMENSION ATOT(3),BCNT(3) 3887 CCC
3823 CCC 3888 CCC SDWEAK=0.0
3824 CCC IF(OMEGA.GT.5725.)GO TO 300 3889 CCC
3825 CCC 3890 CCC DO 510 K=1,3
3826 CCC WM=44. 3891 CCC
3827 CCC 3892 CCC SDWEAK=SDWEAK+ATOT(K)*C2/(4.*BE*TEMP)*ABS(OMEGA-BCNT(K))
3828 CCC GD=5.94E-6*OMEGA*(TEMP/(273.*WM))**.5 3893 CCC
3829 CCC 3894 CCC 1*EXP(-C2/(4.*BE*TEMP)*(OMEGA-BCNT(K))**2)
3830 CCC IF(OMEGA.GT.4550.)GO TO 500 3895 CCC
3831 CCC 3896 CCC510 CONTINUE
3832 CCC IF(OMEGA.GT.3800.)GO TO 300 3897 CCC
3833 CCC 3898 CCC DINV=1./(4.*BE)
3834 CCC IF(OMEGA.GT.3050.)GO TO 100 3899 CCC
3835 CCC 3900 CCC GDINV=GC1*DINV
3901 CCC 3966 CCC V=FLOAT(J-1)
3902 CCC GDDINV=GD*DINV 3967 CCC
3903 CCC 3968 CCC IF(J/2*2.EQ.J)G=(V+1.)*(V+3.)/4.
3904 CCCC***EXPRESS S/D AT STP, AS IS IN NASA SP-3080 3969 CCC
3905 CCC 3970 CCC IF(J/2*2.NE.J)G=(V+2.)*(V+2.)/4.
3906 CCC SDWEAK=SDWEAK*TEMP/273. 3971 CCC
3907 CCC 3972 CCC VBAR1=-1.+(V+3.)*(V+4.)/(V+2.)/6.
3908 CCC RETURN 3973 CCC
3909 CCC 3974 CCC IF(J/2*2.EQ.J)VBAR1=-1.+(V+5.)/6.
3910 CCC100 CONTINUE 3975 CCC
3911 CCC 3976 CCC DO 101 K=1,10
3912 CCC B=.391635 3977 CCC
3913 CCC 3978 CCC V3=FLOAT(K-1)
3914 CCC A=.0030875 3979 CCC
3915 CCC 3980 CCC DD=(V3+1)*G*EXP(-(V3*OM3+V*OM12)*C2/TEMP)*(VBAR1+1.)
3916 CCC X13=-19.37 3981 CCC
3917 CCC 3982 CCC GAM=B-A*(V3+1.)
3918 CCC X23=-12.53 3983 CCC
3919 CCC 3984 CCC IF(L.EQ.2)GO TO 125
3920 CCC X33=-12.63 3985 CCC
3921 CCC 3986 CCC OMVV3=3598.-18.*V-47.*V3
3922 CCC OM1=1354.91 3987 CCC
3923 CCC 3988 CCC IF(V.EQ.0.)OMVV3=3613.-47.*V3
3924 CCC OM2=673. 3989 CCC
3925 CCC 3990 CCC GO TO 130
3926 CCC OM3=2396.49 3991 CCC
3927 CCC 3992 CCC125 OMVV3=3728.-5.*V-47.*V3
3928 CCC T0=300. 3993 CCC
3929 CCC 3994 CCC IF(V.EQ.0.)OMVV3=3715.-47.*V3
3930 CCC C2=1.4388 3995 CCC
3931 CCC 3996 CCC130 DELTA=A*(OMEGA-OMVV3)
3932 CCC XBAR=.5*(.5*X13+X23) 3997 CCC
3933 CCC 3998 CCC IF(GAM*GAM.LE.DELTA)GO TO 102
3934 CCC OM12=.5*(.5*OM1+OM2) 3999 CCC
3935 CCC 4000 CCC D=2.*(GAM*GAM-DELTA)**.5
3936 CCC SDWEAK=0. 4001 CCC
3937 CCC 4002 CCC OMVBAR=OMVV3*(1.-EXP(-OMVV3*C2/TEMP))
3938 CCC SDSTRG=0. 4003 CCC
3939 CCC 4004 CCC F1=GAM-D/2
3940 CCC IF(OMEGA.LE.2395.)GO TO 200 4005 CCC
3941 CCC 4006 CCC F2=GAM+D/2.
3942 CCCCALCULATE ABSORPTION COEF. AND LINE SPACING PARAMETER FOR 2.7 MICRON BAND 4007 CCC
3943 CCC 4008 CCC EE=C2*GAM/(A*A*TEMP)
3944 CCC L=1 4009 CCC
3945 CCC 4010 CCC UNFLO1=EE*DELTA*(1.+.5*A/GAM)
3946 CCCCONTRIBUTION TO 2.7 MICRON BAND FROM (000)-(021) AND (010)-(031) TRANS. 4011 CCC
3947 CCC 4012 CCC IF(UNFLO1.LE.-78.)GO TO 102
3948 CCC ALPHA=28.5 4013 CCC
3949 CCC 4014 CCC UNFLO2=EE*2.*GAM*F1
3950 CCC OMPRIM=2.*OM2+OM3 4015 CCC
3951 CCC 4016 CCC IF(UNFLO2.GE.78.)GO TO 102
3952 CCC120 AA=ALPHA*B*C2/(A*(1.-EXP(-OM3*C2/T0))*(1.-EXP(-OM12*C2/T0))**3 4017 CCC
3953 CCC 4018 CCC FF=DEXP(EE*DELTA*(1.+.5*A/GAM))
3954 CCC 1*(1.+EXP(-OM12*C2/T0))*(1.-EXP(-OMPRIM*C2/T0))) 4019 CCC
3955 CCC 4020 CCC SMINUS=CC*DD/OMVBAR*ABS(F1)*FF*DEXP(-EE*2.*GAM*F1)
3956 CCC BB=(1.-EXP(-C2*OMEGA/TEMP))*(1.-EXP(-C2*OM3/TEMP))* 4021 CCC
3957 CCC 4022 CCC UNFLO3=EE*2.*GAM*F2
3958 CCC 1(1.-EXP(-OM12*C2/TEMP))**3*(1.+EXP(-OM12*C2/TEMP)) 4023 CCC
3959 CCC 4024 CCC IF(UNFLO3.GE.78.)GO TO 160
3960 CCC 2 *(1.-EXP(-C2*OMPRIM/TEMP)) 4025 CCC
3961 CCC 4026 CCC SPLUS=CC*DD/OMVBAR*ABS(F2)*FF*DEXP(-EE*2.*GAM*F2)
3962 CCC CC=AA*BB*OMEGA/TEMP*T0/TEMP 4027 CCC
3963 CCC 4028 CCC GO TO 170
3964 CCC DO 102 J=1,20 4029 CCC
3965 CCC 4030 CCC160 SPLUS=0.

4031 CCC 4096 CCC IF(GAM*GAM.LE.DELTA)GO TO 202

4032 CCC170 GG=SDWEAK 4097 CCC
4033 CCC 4098 CCC D=2.*(GAM*GAM-DELTA)**.5
4034 CCC SDWEAK=(SMINUS+SPLUS)/D+SDWEAK 4099 CCC
4035 CCC 4100 CCC OMVBAR=OMVV3*(1.-EXP(-OMVV3*C2/TEMP))
4036 CCC TEST=(SDWEAK-GG)/SDWEAK 4101 CCC
4037 CCC 4102 CCC F1=GAM-D/2
4038 CCC IF(TEST.LT..0001)GO TO 102 4103 CCC
4039 CCC 4104 CCC F2=GAM+D/2.
4040 CCC SDSTRG=(.5*G)**.5*(SMINUS**.5+SPLUS**.5)/D+SDSTRG 4105 CCC
4041 CCC 4106 CCC EE=C2*GAM/(A*A*TEMP)
4042 CCC101 CONTINUE 4107 CCC
4043 CCC 4108 CCC UNFLO1=EE*DELTA*(1.+.5*A/GAM)
4044 CCC102 CONTINUE 4109 CCC
4045 CCC 4110 CCC IF(UNFLO1.LE.-78.)GO TO 202
4046 CCC IF(L.EQ.2)GO TO 250 4111 CCC
4047 CCC 4112 CCC UNFLO2=EE*2.*GAM*F1
4048 CCCCONTRIBUTION TO 2.7 MICRON BAND FROM (000)-(101) AND (010)-(111) TRANS. 4113 CCC
4049 CCC 4114 CCC IF(UNFLO2.GE.78.)GO TO 202
4050 CCC ALPHA=42.3 4115 CCC
4051 CCC 4116 CCC FF=DEXP(EE*DELTA*(1.+.5*A/GAM))
4052 CCC OMPRIM=OM1+OM3 4117 CCC
4053 CCC 4118 CCC SMINUS=CC*DD/OMVBAR*ABS(F1)*FF*DEXP(-EE*2.*GAM*F1)
4054 CCC L=2 4119 CCC
4055 CCC 4120 CCC UNFLO3=EE*2.*GAM*F2
4056 CCC GO TO 120 4121 CCC
4057 CCC 4122 CCC IF(UNFLO3.GE.78.)GO TO 246
4058 CCCCALCULATE ABSORPTION COEF AND LINE SPACING PARAMETER FOR 4.3 MICRON BAND 4123 CCC
4059 CCC 4124 CCC SPLUS=CC*DD/OMVBAR*ABS(F2)*FF*DEXP(-EE*2.*GAM*F2)
4060 CCC200 ALPHA=2700. 4125 CCC
4061 CCC 4126 CCC GO TO 247
4062 CCC OMPRIM=OM3 4127 CCC
4063 CCC 4128 CCC246 SPLUS=0.
4064 CCC AA=ALPHA*B*C2/(A*(1.-EXP(-OM3*C2/T0))*(1.-EXP(-OM12*C2/T0))**3 4129 CCC
4065 CCC 4130 CCC247 GG=SDWEAK
4066 CCC 1*(1.+EXP(-OM12*C2/T0))*(1.-EXP(-OMPRIM*C2/T0))) 4131 CCC
4067 CCC 4132 CCC SDWEAK=(SMINUS+SPLUS)/D+SDWEAK
4068 CCC BB=(1.-EXP(-C2*OMEGA/TEMP))*(1.-EXP(-C2*OM3/TEMP))* 4133 CCC
4069 CCC 4134 CCC TEST=(SDWEAK-GG)/SDWEAK
4070 CCC 1(1.-EXP(-OM12*C2/TEMP))**3*(1.+EXP(-OM12*C2/TEMP)) 4135 CCC
4071 CCC 4136 CCC IF(TEST.LT..0001)GO TO 202
4072 CCC 2 *(1.-EXP(-C2*OMPRIM/TEMP)) 4137 CCC
4073 CCC 4138 CCC SDSTRG=(.5*G)**.5*(SMINUS**.5+SPLUS**.5)/D+SDSTRG
4074 CCC CC=AA*BB*OMEGA/TEMP*T0/TEMP 4139 CCC
4075 CCC 4140 CCC201 CONTINUE
4076 CCC DO 202 J=1,20 4141 CCC
4077 CCC 4142 CCC202 CONTINUE
4078 CCC V=FLOAT(J-1) 4143 CCC
4079 CCC 4144 CCC250 CONTINUE
4080 CCC IF(J/2*2.EQ.J)G=(V+1.)*(V+3.)/4. 4145 CCC
4081 CCC 4146 CCC IF(SDWEAK.EQ.0.)GO TO 300
4082 CCC IF(J/2*2.NE.J)G=(V+2.)*(V+2.)/4. 4147 CCC
4083 CCC 4148 CCC DINV=SDSTRG*SDSTRG/SDWEAK
4084 CCC DO 201 K=1,10 4149 CCC
4085 CCC 4150 CCC GDINV=GC1*DINV
4086 CCC V3=FLOAT(K-1) 4151 CCC
4087 CCC 4152 CCC GDDINV=GD*DINV
4088 CCC DD=(V3+1.)*G*EXP(-(V3*OM3+V*OM12)*C2/TEMP) 4153 CCC
4089 CCC 4154 CCCC***EXPRESS S/D AT STP, AS IS K IN NASA SP-3080
4090 CCC GAM=B-A*(V3+1.) 4155 CCC
4091 CCC 4156 CCC SDWEAK=SDWEAK*TEMP/273.
4092 CCC OMVV3=OM3+.5*X13+X23+2.*X33+XBAR*V+2.*X33*V3 4157 CCC
4093 CCC 4158 CCC RETURN
4094 CCC DELTA=A*(OMEGA-OMVV3) 4159 CCC
4095 CCC 4160 CCCCONTRIBUTION TO 10.0 MICRON BAND FROM (100)-(001) AND (020)-(001) TRANS.
4161 CCC 4226 CCC WW=(OMEGA-W1)/5
4162 CCC600 OM1=1354.91 4227 CCC
4163 CCC 4228 CCC IF(TEMP.GT.2400.)TEMP=2399.99
4164 CCC OM2=673. 4229 CCC
4165 CCC 4230 CCC IF(TEMP.LT.300.)TEMP=300.
4166 CCC OM3=2396.49 4231 CCC
4167 CCC 4232 CCC I=TEMP/300.
4168 CCC C2=1.4388 4233 CCC
4169 CCC 4234 CCC IF((I.GT.2).AND.(TEMP.LT.1200.))GO TO 410
4170 CCC BCNT(1)=960.8 4235 CCC
4171 CCC 4236 CCC IF((I.GT.5).AND.(TEMP.LT.2400.))GO TO 420
4172 CCC BCNT(2)=1063.6 4237 CCC
4173 CCC 4238 CCC T1=FLOAT(I)*300.
4174 CCC OMA=OM3 4239 CCC
4175 CCC 4240 CCC TT=(TEMP-T1)/300.
4176 CCC OMB=(OM1+2.*OM2)/2. 4241 CCC
4177 CCC 4242 CCC IF(I.GT.4)I=I-1
4178 CCC TO=300. 4243 CCC
4179 CCC 4244 CCC GO TO 430
4180 CCC ATOT(1)=0.0219 4245 CCC
4181 CCC 4246 CCC410 I=2
4182 CCC ATOT(2)=0.0532 4247 CCC
4183 CCC 4248 CCC TT=(TEMP-600.)/600.
4184 CCC BE=0.391635 4249 CCC
4185 CCC 4250 CCC GO TO 430
4186 CCC DO 610 K=1,2 4251 CCC
4187 CCC 4252 CCC420 I=5
4188 CCC ATOT(K)=TO/TEMP*ATOT(K)*EXP(C2*OMB*(1./TO-1./TEMP)) 4253 CCC
4189 CCC 4254 CCC TT=(TEMP-1800.)/600.
4190 CCC 1*(1.-EXP(-C2*(OMA-OMB)/TEMP))/(1.-EXP(-C2*OMA/TEMP)) 4255 CCC
4191 CCC 4256 CCC430 TW=TT*WW
4192 CCC 2/(1.-EXP(-OMB*C2/TEMP)) 4257 CCC
4193 CCC 4258 CCC SDWEAK=SD15(I,J)*(1.-TT-WW+TW)+SD15(I+1,J)*(TT-TW)
4194 CCC610 CONTINUE 4259 CCC
4195 CCC 4260 CCC 1+SD15(I,J+1)*(WW-TW)+SD15(I+1,J+1)*TW
4196 CCC SDWEAK=0. 4261 CCC
4197 CCC 4262 CCC IF(SDWEAK.EQ.0.)GO TO 300
4198 CCC DO 620 I=1,2 4263 CCC
4199 CCC 4264 CCCCALCULATE LINE SPACING PARAMETER FOR 15.0 MICRON BAND
4200 CCC SDWEAK=SDWEAK+ATOT(I)*C2/(4.*BE*TEMP)*ABS(OMEGA-BCNT(I)) 4265 CCC
4201 CCC 4266 CCC DINV1=1.2
4202 CCC 1*EXP(-C2/(4.*BE*TEMP)*(OMEGA-BCNT(I))**2) 4267 CCC
4203 CCC 4268 CCC DINV2=8.0
4204 CCC620 CONTINUE 4269 CCC
4205 CCC 4270 CCC DINV3=30.0
4206 CCC DINV=1./4./BE 4271 CCC
4207 CCC 4272 CCC TEMP1=300.0
4208 CCC GDINV=GC1*DINV 4273 CCC
4209 CCC 4274 CCC TEMP2=550.0
4210 CCC GDDINV=GD*DINV 4275 CCC
4211 CCC 4276 CCC TEMP3=830.0
4212 CCCC***EXPRESS S/D AT STP, AS IS IN NASA SP-3080 4277 CCC
4213 CCC 4278 CCC DINV=DINV1*(TEMP-TEMP2)*(TEMP-TEMP3)/(TEMP1-TEMP2)/
4214 CCC SDWEAK=SDWEAK*TEMP/273. 4279 CCC
4215 CCC 4280 CCC 1(TEMP1-TEMP3)+DINV2*(TEMP-TEMP1)*(TEMP-TEMP3)/(TEMP2-TEMP1)
4216 CCC RETURN 4281 CCC
4217 CCC 4282 CCC 2/(TEMP2-TEMP3)+DINV3*(TEMP-TEMP1)*(TEMP-TEMP2)/(TEMP3-TEMP1)
4218 CCCCONTRIBUTION TO 15.0 MICRON BAND FROM (000)-(010) TRANS. 4283 CCC
4219 CCC 4284 CCC 3/(TEMP3-TEMP2)
4220 CCC400 TTEMP=TEMP 4285 CCC
4221 CCC 4286 CCC GDINV=GC1*DINV
4222 CCC J=(OMEGA-495.)/5. 4287 CCC
4223 CCC 4288 CCC GDDINV=GD*DINV
4224 CCC W1=495.+5.*FLOAT(J) 4289 CCC
4225 CCC 4290 CCC RETURN

4291 CCC 4356 CCC D=-2.294+.3004E-02*TEMP-.366E-06*TEMP**2

4292 CCC300 SDWEAK=0. 4357 CCC
4293 CCC 4358 CCC B=SIN(.0036*OMEGA-8.043)
4294 CCC GDINV=1. 4359 CCC
4295 CCC 4360 CCC DINV=EXP(.7941*B+D)
4296 CCC GDDINV=1. 4361 CCC
4297 CCC 4362 CCCC DINV=EXP(0.00106*TEMP-1.21)
4298 CCC RETURN 4363 CCC
4299 CCC 4364 CCC GDINV=GC2*DINV
4300 CCC END 4365 CCC
4301 CCC 4366 CCC GDDINV=GD*DINV
4302 CCCC 4367 CCC
4303 CCC 4368 CCC TEMP=TTEMP
4304 CCCC**************************************************************************** 4369 CCC
4305 CCC 4370 CCC RETURN
4306 CCCC 4371 CCC
4307 CCC 4372 CCC200 CONTINUE
4308 CCC SUBROUTINE H2O(OMEGA,TEMP,GC2,SDWEAK,GDINV,GDDINV) 4373 CCC
4309 CCC 4374 CCC SDWEAK=0.
4310 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 4375 CCC
4311 CCC 4376 CCC GDINV=1.
4312 CCC DOUBLE PRECISION SDWEAK,GDINV,GDDINV 4377 CCC
4313 CCC 4378 CCC GDDINV=1.
4314 CCC COMMON/CH2O/SD(6,376) 4379 CCC
4315 CCC 4380 CCC RETURN
4316 CCC IF (OMEGA.GE.9300..OR.OMEGA.LT.50.)GO TO 200 4381 CCC
4317 CCC 4382 CCC END
4318 CCC WM=18. 4383 CCC
4319 CCC 4384 CCCC
4320 CCC GD=5.94E-6*OMEGA*(TEMP/(273.*WM))**.5 4385 CCC
4321 CCC 4386 CCCC***********************************************************************
4322 CCC J=(OMEGA-25.)/25. 4387 CCC
4323 CCC 4388 CCCC
4324 CCC TTEMP=TEMP 4389 CCC
4325 CCC 4390 CCC SUBROUTINE CO(OMEGA,TEMP,GC4,SDWEAK,GDINV,GDDINV)
4326 CCC IF(TEMP.GE.2500.) TEMP=2499.99 4391 CCC
4327 CCC 4392 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
4328 CCC IF(TEMP.LT.300.) TEMP=300. 4393 CCC
4329 CCC 4394 CCC DOUBLE PRECISION AA,BB,CC,DD,EE,FF,GG,SMINUS,SPLUS,SDWEAK,SDSTRG
4330 CCC I=TEMP/500. +1 4395 CCC
4331 CCC 4396 CCC 2,GDINV,GDDINV
4332 CCC IF(I.EQ.2.AND.TEMP.LT.600.) I=1 4397 CCC
4333 CCC 4398 CCC IF(OMEGA.LT.1600.OR.OMEGA.GT.2400.) GO TO 300
4334 CCC W1=25.+25.*FLOAT(J) 4399 CCC
4335 CCC 4400 CCC B=1.93139
4336 CCC WW=(OMEGA-W1)/25. 4401 CCC
4337 CCC 4402 CCC ALPHA=260.
4338 CCC IF(I.GT.2) GO TO 75 4403 CCC
4339 CCC 4404 CCC A=.017485
4340 CCC IF(I.EQ.1) TT=(TEMP-300.)/300. 4405 CCC
4341 CCC 4406 CCC OME=2170.21
4342 CCC IF(I.EQ.2) TT=(TEMP-600.)/400. 4407 CCC
4343 CCC 4408 CCC WX=13.461
4344 CCC GO TO 100 4409 CCC
4345 CCC 4410 CCC WY=.0308
4346 CCC75 T1=FLOAT(I-1)*500. 4411 CCC
4347 CCC 4412 CCC OMPRIM=OME-2.*WX+3.25*WY
4348 CCC TT=(TEMP-T1)/500. 4413 CCC
4349 CCC 4414 CCC T0=300.
4350 CCC100 TW=TT*WW 4415 CCC
4351 CCC 4416 CCC C2=1.4388
4352 CCC SDWEAK=SD(I,J)*(1.-TT-WW+TW)+SD(I+1,J)*(TT-TW)+SD(I,J+1)*(WW-TW) 4417 CCC
4353 CCC 4418 CCC WM=28.
4354 CCC 1 +SD(I+1,J+1)*TW 4419 CCC
4355 CCC 4420 CCC GD=5.94E-6*OMEGA*(TEMP/(273.*WM))**.5
4421 CCC 4486 CCC300 SDWEAK=0.
4422 CCC SDWEAK=1.D-99 4487 CCC
4423 CCC 4488 CCC GDINV=1.
4424 CCC SDSTRG=1.D-99 4489 CCC
4425 CCC 4490 CCC GDDINV=1.
4426 CCC AA=ALPHA*B*C2/(A*(1.-EXP(-OMPRIM*C2/T0))**2) 4491 CCC
4427 CCC 4492 CCC RETURN
4428 CCC BB=(1.-EXP(-OMEGA*C2/TEMP))*(1.-EXP(-OMPRIM*C2/TEMP))**2 4493 CCC
4429 CCC 4494 CCC END
4430 CCC CC=AA*BB*OMEGA/TEMP*T0/TEMP 4495 CCC
4431 CCC 4496 CCCC
4432 CCC DO 101 J=1,20 4497 CCC
4433 CCC 4498 CCCC****************************************************************************
4434 CCC V=FLOAT(J-1) 4499 CCC
4435 CCC 4500 CCCC
4436 CCC DD=(V+1.)*EXP(-V*OME*C2/TEMP) 4501 CCC
4437 CCC 4502 CCC SUBROUTINE POD(OMEGA)
4438 CCC GAM=B-A*(V+1.) 4503 CCC
4439 CCC 4504 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
4440 CCC OMV=OME-2.*(V+1.)*WX+(3.*(V+1.)*(V+1.)+.25)*WY 4505 CCC
4441 CCC 4506 CCCC***POD CALCULATES PARTICLE OPTICAL DEPTH, XPART, OF THE VOLUME
4442 CCC DELTA=A*(OMEGA-OMV) 4507 CCC
4443 CCC 4508 CCCC FRACTION OF SOOT PARTICLES IN GAS CLOUD. RIN AND RIK ARE
4444 CCC IF(GAM*GAM.LE.DELTA) GO TO 102 4509 CCC
4445 CCC 4510 CCCC THE REAL AND IMAGINARY PARTS OF THE INDEX OF REFRACTION. THE
4446 CCC D=2.*(GAM*GAM-DELTA)**.5 4511 CCC
4447 CCC 4512 CCCC PARTICLES ARE ASSUMED TO BE IN THE RAYLEIGH LIMIT.
4448 CCC OMVBAR=OMV*(1.-EXP(-OMV*C2/TEMP)) 4513 CCC
4449 CCC 4514 CCCC
4450 CCC F1=GAM-D/2. 4515 CCC
4451 CCC 4516 CCC COMMON/CPART/W(100),XPART(100),T(100),DD(100),NPT
4452 CCC F2=GAM+D/2. 4517 CCC
4453 CCC 4518 CCC AMBDA=10000./OMEGA
4454 CCC EE=C2*GAM/(A*A*TEMP) 4519 CCC
4455 CCC 4520 CCC RIN=1.6
4456 CCC FF=DEXP(EE*DELTA*(1.+.5*A/GAM)) 4521 CCC
4457 CCC 4522 CCC RIK=.5
4458 CCC SMINUS=CC*DD/OMVBAR*ABS(F1)*FF*DEXP(-EE*2.*GAM*F1) 4523 CCC
4459 CCC 4524 CCCC FF=36.*3.1416*RIN*RIK/AMBDA/((RIN*RIN-RIK*RIK+2.)**2+(2.*RIN*RIK)
4460 CCC SPLUS=CC*DD/OMVBAR*ABS(F2)*FF*DEXP(-EE*2.*GAM*F2) 4525 CCC
4461 CCC 4526 CCCC 2**2)
4462 CCC GG=SDWEAK 4527 CCC
4463 CCC 4528 CCCC
4464 CCC SDWEAK=(SMINUS+SPLUS)/D+SDWEAK 4529 CCC
4465 CCC 4530 CCCC ABSORPTION COEF. IS BASED UPON MEASUREMENTS OF DALZELL AND
4466 CCC TEST=(SDWEAK-GG)/SDWEAK 4531 CCC
4467 CCC 4532 CCCC SAROFIM.
4468 CCC IF(TEST.LT..0001) GO TO 102 4533 CCC
4469 CCC 4534 CCC FF=7./AMBDA
4470 CCC SDSTRG=(SMINUS**.5+SPLUS**.5)/D+SDSTRG 4535 CCC
4471 CCC 4536 CCC DO 300 J=1,NPT
4472 CCC101 CONTINUE 4537 CCC
4473 CCC 4538 CCC ABCO=FF*W(J)*1.E06
4474 CCC102 DINV=SDSTRG*SDSTRG/SDWEAK 4539 CCC
4475 CCC 4540 CCC IF(J.EQ.1)GO TO 290
4476 CCC GDINV=GC4*DINV 4541 CCC
4477 CCC 4542 CCC XPART(J)=XPART(J-1)+ABCO*DD(J)
4478 CCC GDDINV=GD*DINV 4543 CCC
4479 CCC 4544 CCC GO TO 300
4480 CCCC***EXPRESS S/D AT STP, AS IS K IN NASA SP-3080 4545 CCC
4481 CCC 4546 CCC290 XPART(1)=ABCO*DD(1)
4482 CCC SDWEAK=SDWEAK*TEMP/273. 4547 CCC
4483 CCC 4548 CCC300 CONTINUE
4484 CCC RETURN 4549 CCC
4485 CCC 4550 CCC RETURN

4551 CCC 4616 CCC BCNT(2)=4216.3

4552 CCC END 4617 CCC
4553 CCC 4618 CCC BCNT(3)=4313.2
4554 CCCC 4619 CCC
4555 CCC 4620 CCC BCNT(4)=4546.0
4556 CCCC**************************************************************************** 4621 CCC
4557 CCC 4622 CCC COM1=OM2+2.*OM4
4558 CCCC 4623 CCC
4559 CCC 4624 CCC COM2=OM1+OM4
4560 CCC SUBROUTINE FUEL(OMEGA,TEMP,PCH4,PTOT,GC3,SDWEAK,GDINV,GDDINV) 4625 CCC
4561 CCC 4626 CCC COM3=OM3+OM4
4562 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N) 4627 CCC
4563 CCC 4628 CCC COM4=OM2+OM3
4564 CCC COMMON/CCH4/SD7(3,16),SD3(3,32) 4629 CCC
4565 CCC 4630 CCC ATOT(1)=.64*273./TEMP**(1.-EXP(-C2*COM1/TEMP))/
4566 CCC DOUBLE PRECISION SDWEAK,GDINV,GDDINV 4631 CCC
4567 CCC 4632 CCC 2(1.-EXP(-C2*OM2/TEMP))/(1.-EXP(-C2*OM4/TEMP))**2
4568 CCC DIMENSION BCNT(4),ATOT(4) 4633 CCC
4569 CCC 4634 CCC ATOT(2)=17.6*273./TEMP*(1.-EXP(-C2*COM2/TEMP))/
4570 CCC IF(OMEGA.GT.5000..OR.OMEGA.LT.1125.)GO TO 100 4635 CCC
4571 CCC 4636 CCC 2(1.-EXP(-C2*OM1/TEMP))/(1.-EXP(-C2*OM4/TEMP))
4572 CCC PI=3.14159 4637 CCC
4573 CCC 4638 CCC ATOT(3)=14.8*273./TEMP*(1.-EXP(-C2*COM3/TEMP))/
4574 CCC BE=5.2412 4639 CCC
4575 CCC 4640 CCC 2(1.-EXP(-C2*OM3/TEMP))/(1.-EXP(-C2*OM4/TEMP))
4576 CCC C2=1.4388 4641 CCC
4577 CCC 4642 CCC ATOT(4)=5.04*273./TEMP*(1.-EXP(-C2*COM4/TEMP))/
4578 CCC WM=16. 4643 CCC
4579 CCC 4644 CCC 2(1.-EXP(-C2*OM2/TEMP))/(1.-EXP(-C2*OM3/TEMP))
4580 CCC GD=5.94E-6*OMEGA*(TEMP/(273.*WM))**.5 4645 CCC
4581 CCC 4646 CCC DINV=1./5.74
4582 CCC IF(OMEGA.GT.3400.)GO TO 50 4647 CCC
4583 CCC 4648 CCC GDINV=GC3*DINV
4584 CCC PE=PTOT+.3*PCH4 4649 CCC
4585 CCC 4650 CCC GDDINV=GD*DINV
4586 CCC IF(OMEGA.GE.2625.)GO TO 200 4651 CCC
4587 CCC 4652 CCC SDWEAK=0.0
4588 CCC IF(OMEGA.GT.1450.)GO TO 100 4653 CCC
4589 CCC 4654 CCC DO 51 I=1,4
4590 CCC GO TO 300 4655 CCC
4591 CCC 4656 CCC SDWEAK=SDWEAK+2.*(OMEGA-BCNT(I))**2*(C2*BE/TEMP)**1.5*ATOT(I)
4592 CCCC 4657 CCC
4593 CCC 4658 CCC 2/PI**0.5*DINV**3*EXP(-C2*BE*DINV**2/TEMP*(OMEGA-BCNT(I))**2)
4594 CCCC CONTRIBUTION TO 2.4 MICRON BAND FROM (0000)-(0110), (0000)-(0011), 4659 CCC
4595 CCC 4660 CCC51 CONTINUE
4596 CCCC (0000)-(1001), AND (0000)-(0102) TRANS. THE INTEGRATED BAND INTENSITIES 4661 CCC
4597 CCC 4662 CCC SDWEAK=SDWEAK*(TEMP/273.)
4598 CCCC OF VINCENT-GEISSE (ANNALES DE PHYSIQUE SER.12, V. 10, 1955) HAVE 4663 CCC
4599 CCC 4664 CCC RETURN
4600 CCCC BEEN MULTIPLIED BY A FACTOR OF 4 AND THE LINE SPACING IS THAT 4665 CCC
4601 CCC 4666 CCCC
4602 CCCC OF V4 FROM GRAY AND PENNER (JQSRT V. 5, 1965). 4667 CCC
4603 CCC 4668 CCCCONTRIBUTION TO 3.3 MICRON BAND FROM (0000)-(0010) TRANS.
4604 CCCC 4669 CCC
4605 CCC 4670 CCCC REFER TO BROSMER AND TIEN, JQSRT V. 33, P. 521
4606 CCC50 OM1=2914.2 4671 CCC
4607 CCC 4672 CCC200 CONTINUE
4608 CCC OM2=1526.0 4673 CCC
4609 CCC 4674 CCC GDINV=.00734*PE*(273./TEMP)**.5*EXP(1.02*(TEMP-273.)/273.)
4610 CCC OM3=3020.3 4675 CCC
4611 CCC 4676 CCC GDDINV=GD/9.4
4612 CCC OM4=1306.2 4677 CCC
4613 CCC 4678 CCC J=(OMEGA-2600.)/25.
4614 CCC BCNT(1)=4123.0 4679 CCC
4615 CCC 4680 CCC W1=2600.+25.*FLOAT(J)
4681 CCC 4746 CCC END
4682 CCC SDB=SD3(2,J)+(OMEGA-W1)/25.*(SD3(2,J+1)-SD3(2,J)) 4747 CCC
4683 CCC 4748 CCCC
4684 CCC IF(TEMP.GT.600.)GO TO 260 4749 CCC
4685 CCC 4750 CCCC*******************************************************************************
4686 CCC SDA=SD3(1,J)+(OMEGA-W1)/25.*(SD3(1,J+1)-SD3(1,J)) 4751 CCC
4687 CCC 4752 CCCC
4688 CCC SDWEAK=SDA+(TEMP-290.)/310.*(SDB-SDA) 4753 CCC
4689 CCC 4754 CCC FUNCTION PLANCK(A,B)
4690 CCC IF(SDWEAK.LT.0.)SDWEAK=0. 4755 CCC
4691 CCC 4756 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
4692 CCC RETURN 4757 CCC
4693 CCC 4758 CCCC COMPUTES BLACKBODY FUNCTION IN UNITS OF W/M-2/MICRON/SR
4694 CCC260 SDC=SD3(3,J)+(OMEGA-W1)/25.*(SD3(3,J+1)-SD3(3,J)) 4759 CCC
4695 CCC 4760 CCC C1=.59544E08
4696 CCC SDWEAK=SDB+(TEMP-600.)/250.*(SDC-SDB) 4761 CCC
4697 CCC 4762 CCC C2=14388.
4698 CCC IF(SDWEAK.LT.0.)SDWEAK=0. 4763 CCC
4699 CCC 4764 CCC IF(A.EQ.0.)GO TO 100
4700 CCC RETURN 4765 CCC
4701 CCC 4766 CCC OVRFLO=C2/A/B
4702 CCCC 4767 CCC
4703 CCC 4768 CCC IF(OVRFLO.GT.38.)GO TO 100
4704 CCCCONTRIBUTION TO 7.7 MICRON BAND FROM (0000)-(0001) TRANS. 4769 CCC
4705 CCC 4770 CCC PLANCK=2.*C1*(B**(-5))/(EXP(C2/A/B)-1.)
4706 CCCC REFER TO BROSMER AND TIEN, JQSRT V. 33, P. 521. 4771 CCC
4707 CCC 4772 CCC GO TO 101
4708 CCC300 CONTINUE 4773 CCC
4709 CCC 4774 CCC100 PLANCK=0.
4710 CCC GDINV=.0243*PE*(TEMP/273.)**.8 4775 CCC
4711 CCC 4776 CCC101 CONTINUE
4712 CCC GDDINV=GD/5.1 4777 CCC
4713 CCC 4778 CCC RETURN
4714 CCC J=(OMEGA-1100.)/25. 4779 CCC
4715 CCC 4780 CCC END
4716 CCC W1=1100.+25.*FLOAT(J) 4781 CCC
4717 CCC 4782 CCC
4718 CCC SDB=SD7(2,J)+(OMEGA-W1)/25.*(SD7(2,J+1)-SD7(2,J)) 4783 CCC
4719 CCC 4784 CCC BLOCK DATA BD1
4720 CCC IF(TEMP.GT.600.)GO TO 360 4785 CCC
4721 CCC 4786 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
4722 CCC SDA=SD7(1,J)+(OMEGA-W1)/25.*(SD7(1,J+1)-SD7(1,J)) 4787 CCC
4723 CCC 4788 CCC COMMON/CH2O/SD(6,376)
4724 CCC SDWEAK=SDA+(TEMP-290.)/310.*(SDB-SDA) 4789 CCC
4725 CCC 4790 CCC DIMENSION A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(6,8),A7(6,8),
4726 CCC IF(SDWEAK.LT.0.)SDWEAK=0. 4791 CCC
4727 CCC 4792 CCC 2A8(6,8),A9(6,8),A10(6,8),A11(6,8),A12(6,8),A13(6,8),A14(6,8),
4728 CCC RETURN 4793 CCC
4729 CCC 4794 CCC 3A15(6,8),A16(6,8),A17(6,8),A18(6,8),A19(6,8),A20(6,8),A21(6,8)
4730 CCC360 SDC=SD7(3,J)+(OMEGA-W1)/25.*(SD7(3,J+1)-SD7(3,J)) 4795 CCC
4731 CCC 4796 CCC EQUIVALENCE(A1(1,1),SD(1,1)),(A2(1,1),SD(1,9)),(A3(1,1),SD(1,17))
4732 CCC SDWEAK=SDB+(TEMP-600.)/250.*(SDC-SDB) 4797 CCC
4733 CCC 4798 CCC 1,(A4(1,1),SD(1,25)),(A5(1,1),SD(1,33)),(A6(1,1),SD(1,41))
4734 CCC IF(SDWEAK.LT.0.)SDWEAK=0. 4799 CCC
4735 CCC 4800 CCC 2,(A7(1,1),SD(1,49)),(A8(1,1),SD(1,57)),(A9(1,1),SD(1,65))
4736 CCC RETURN 4801 CCC
4737 CCC 4802 CCC 3,(A10(1,1),SD(1,73)),(A11(1,1),SD(1,81)),(A12(1,1),SD(1,89))
4738 CCC100 SDWEAK=0.0 4803 CCC
4739 CCC 4804 CCC 4,(A13(1,1),SD(1,97)),(A14(1,1),SD(1,105)),(A15(1,1),SD(1,113))
4740 CCC GDINV=1. 4805 CCC
4741 CCC 4806 CCC 5,(A16(1,1),SD(1,121)),(A17(1,1),SD(1,129)),(A18(1,1),SD(1,137))
4742 CCC GDDINV=1. 4807 CCC
4743 CCC 4808 CCC 6,(A19(1,1),SD(1,145)),(A20(1,1),SD(1,153)),(A21(1,1),SD(1,161))
4744 CCC RETURN 4809 CCC
4745 CCC 4810 CCCC TEMP,K= 300 600 1000 1500 2000 2500 WAVE NO.

4811 CCC 4876 CCC 1 .680E-07, .620E-03, .590E-01, .443E+00, .103E+01, .156E+01, 750
4812 CCC DATA A1/ 4877 CCC
4813 CCC 4878 CCC 1 .385E-07, .275E-03, .450E-01, .330E+00, .845E+00, .136E+01, 775
4814 CCC 1 .950E+00, .103E+00, .420E-01, .114E-01, .450E-02, .300E-02, 50 4879 CCC
4815 CCC 4880 CCC 1 .670E-07, .113E-03, .355E-01, .242E+00, .695E+00, .117E+01, 800
4816 CCC 1 .208E+01, .365E+00, .113E+00, .375E-01, .195E-01, .134E-01, 75 4881 CCC
4817 CCC 4882 CCC 1 .113E-06, .500E-04, .289E-01, .174E+00, .560E+00, .100E+01/ 825
4818 CCC 1 .368E+01, .990E+00, .300E+00, .104E+00, .577E-01, .365E-01, 100 4883 CCC
4819 CCC 4884 CCC DATA A5/
4820 CCC 1 .650E+01, .201E+01, .650E+00, .214E+00, .128E+00, .845E-01, 125 4885 CCC
4821 CCC 4886 CCC 1 .195E-06, .230E-04, .245E-01, .123E+00, .450E+00, .855E+00, 850
4822 CCC 1 .825E+01, .325E+01, .121E+01, .415E+00, .260E+00, .168E+00, 150 4887 CCC
4823 CCC 4888 CCC 1 .328E-06, .103E-04, .214E-01, .100E+00, .357E+00, .718E+00, 875
4824 CCC 1 .870E+01, .452E+01, .189E+01, .765E+00, .450E+00, .289E+00, 175 4889 CCC
4825 CCC 4890 CCC 1 .560E-06, .460E-05, .189E-01, .830E-01, .278E+00, .595E+00, 900
4826 CCC 1 .810E+01, .540E+01, .261E+01, .126E+01, .695E+00, .460E+00, 200 4891 CCC
4827 CCC 4892 CCC 1 .950E-06, .205E-05, .174E-01, .730E-01, .239E+00, .492E+00, 925
4828 CCC 1 .682E+01, .600E+01, .337E+01, .179E+01, .101E+01, .679E+00/ 225 4893 CCC
4829 CCC 4894 CCC 1 .160E-05, .140E-05, .166E-01, .665E-01, .211E+00, .405E+00, 950
4830 CCC DATA A2/ 4895 CCC
4831 CCC 4896 CCC 1 .275E-05, .350E-05, .165E-01, .630E-01, .195E+00, .352E+00, 975
4832 CCC 1 .493E+01, .622E+01, .407E+01, .230E+01, .135E+01, .935E+00, 250 4897 CCC
4833 CCC 4898 CCC 1 .470E-05, .850E-05, .167E-01, .620E-01, .190E+00, .312E+00, 1000
4834 CCC 1 .316E+01, .592E+01, .456E+01, .281E+01, .172E+01, .122E+01, 275 4899 CCC
4835 CCC 4900 CCC 1 .810E-05, .215E-04, .175E-01, .630E-01, .191E+00, .289E+00/ 1025
4836 CCC 1 .199E+01, .528E+01, .479E+01, .328E+01, .213E+01, .149E+01, 300 4901 CCC
4837 CCC 4902 CCC DATA A6/
4838 CCC 1 .113E+01, .450E+01, .484E+01, .361E+01, .249E+01, .179E+01, 325 4903 CCC
4839 CCC 4904 CCC 1 .136E-04, .570E-04, .188E-01, .675E-01, .194E+00, .281E+00, 1050
4840 CCC 1 .585E+00, .370E+01, .471E+01, .383E+01, .284E+01, .208E+01, 350 4905 CCC
4841 CCC 4906 CCC 1 .235E-04, .150E-03, .208E-01, .745E-01, .202E+00, .283E+00, 1075
4842 CCC 1 .293E+00, .289E+01, .443E+01, .394E+01, .312E+01, .237E+01, 375 4907 CCC
4843 CCC 4908 CCC 1 .400E-04, .380E-03, .233E-01, .865E-01, .223E+00, .314E+00, 1100
4844 CCC 1 .138E+00, .205E+01, .400E+01, .396E+01, .330E+01, .260E+01, 400 4909 CCC
4845 CCC 4910 CCC 1 .680E-04, .950E-03, .268E-01, .122E+00, .260E+00, .380E+00, 1125
4846 CCC 1 .620E-01, .143E+01, .347E+01, .388E+01, .341E+01, .280E+01/ 425 4911 CCC
4847 CCC 4912 CCC 1 .120E-03, .245E-02, .343E-01, .176E+00, .328E+00, .461E+00, 1150
4848 CCC DATA A3/ 4913 CCC
4849 CCC 4914 CCC 1 .200E-03, .620E-02, .638E-01, .251E+00, .411E+00, .511E+00, 1175
4850 CCC 1 .255E-01, .950E+00, .292E+01, .370E+01, .345E+01, .295E+01, 450 4915 CCC
4851 CCC 4916 CCC 1 .365E-03, .140E-01, .107E+00, .330E+00, .458E+00, .542E+00, 1200
4852 CCC 1 .940E-02, .610E+00, .236E+01, .343E+01, .342E+01, .304E+01, 475 4917 CCC
4853 CCC 4918 CCC 1 .680E-03, .330E-01, .166E+00, .405E+00, .487E+00, .571E+00/ 1225
4854 CCC 1 .340E-02, .386E+00, .188E+01, .310E+01, .334E+01, .309E+01, 500 4919 CCC
4855 CCC 4920 CCC DATA A7/
4856 CCC 1 .105E-02, .236E+00, .145E+01, .274E+01, .319E+01, .307E+01, 525 4921 CCC
4857 CCC 4922 CCC 1 .130E-02, .635E-01, .244E+00, .459E+00, .535E+00, .557E+00, 1250
4858 CCC 1 .350E-03, .144E+00, .110E+01, .238E+01, .300E+01, .301E+01, 550 4923 CCC
4859 CCC 4924 CCC 1 .250E-02, .123E+00, .341E+00, .477E+00, .502E+00, .562E+00, 1275
4860 CCC 1 .126E-03, .820E-01, .818E+00, .204E+01, .276E+01, .289E+01, 575 4925 CCC
4861 CCC 4926 CCC 1 .500E-02, .212E+00, .407E+00, .547E+00, .531E+00, .514E+00, 1300
4862 CCC 1 .430E-04, .445E-01, .598E+00, .174E+01, .248E+01, .275E+01, 600 4927 CCC
4863 CCC 4928 CCC 1 .103E-01, .285E+00, .489E+00, .592E+00, .497E+00, .486E+00, 1325
4864 CCC 1 .150E-04, .242E-01, .427E+00, .145E+01, .222E+01, .260E+01/ 625 4929 CCC
4865 CCC 4930 CCC 1 .219E-01, .328E+00, .491E+00, .558E+00, .489E+00, .485E+00, 1350
4866 CCC DATA A4/ 4931 CCC
4867 CCC 4932 CCC 1 .485E-01, .345E+00, .505E+00, .521E+00, .477E+00, .484E+00, 1375
4868 CCC 1 .510E-05, .127E-01, .294E+00, .118E+01, .195E+01, .241E+01, 650 4933 CCC
4869 CCC 4934 CCC 1 .114E+00, .361E+00, .538E+00, .563E+00, .503E+00, .502E+00, 1400
4870 CCC 1 .170E-05, .630E-02, .200E+00, .950E+00, .169E+01, .221E+01, 675 4935 CCC
4871 CCC 4936 CCC 1 .249E+00, .460E+00, .621E+00, .624E+00, .538E+00, .538E+00/ 1425
4872 CCC 1 .570E-06, .300E-02, .134E+00, .748E+00, .146E+01, .200E+01, 700 4937 CCC
4873 CCC 4938 CCC DATA A8/
4874 CCC 1 .195E-06, .140E-02, .902E-01, .580E+00, .124E+01, .178E+01, 725 4939 CCC
4875 CCC 4940 CCC 1 .397E+00, .569E+00, .749E+00, .768E+00, .581E+00, .565E+00, 1450
4941 CCC 5006 CCC 1 .480E-03, .298E-02, .931E-02, .189E-01, .329E-01, .403E-01, 2200
4942 CCC 1 .418E+00, .627E+00, .824E+00, .849E+00, .640E+00, .594E+00, 1475 5007 CCC
4943 CCC 5008 CCC 1 .405E-03, .175E-02, .696E-02, .152E-01, .295E-01, .365E-01/ 2225
4944 CCC 1 .108E+01, .125E+01, .113E+01, .940E+00, .807E+00, .663E+00, 1500 5009 CCC
4945 CCC 5010 CCC DATA A12/
4946 CCC 1 .165E+01, .155E+01, .118E+01, .670E+00, .562E+00, .483E+00, 1525 5011 CCC
4947 CCC 5012 CCC 1 .321E-03, .120E-02, .452E-02, .101E-01, .252E-01, .331E-01, 2250
4948 CCC 1 .142E+01, .675E+00, .557E+00, .349E+00, .276E+00, .263E+00, 1550 5013 CCC
4949 CCC 5014 CCC 1 .229E-03, .721E-03, .364E-02, .930E-02, .225E-01, .305E-01, 2275
4950 CCC 1 .451E+00, .202E+00, .132E+00, .118E+00, .134E+00, .156E+00, 1575 5015 CCC
4951 CCC 5016 CCC 1 .195E-03, .544E-03, .318E-02, .750E-02, .202E-01, .284E-01, 2300
4952 CCC 1 .603E-01, .538E-01, .863E-01, .112E+00, .120E+00, .125E+00, 1600 5017 CCC
4953 CCC 5018 CCC 1 .154E-03, .375E-03, .185E-02, .603E-02, .175E-01, .269E-01, 2325
4954 CCC 1 .501E+00, .252E+00, .118E+00, .112E+00, .131E+00, .140E+00/ 1625 5019 CCC
4955 CCC 5020 CCC 1 .101E-03, .263E-03, .119E-02, .480E-02, .156E-01, .253E-01, 2350
4956 CCC DATA A9/ 5021 CCC
4957 CCC 5022 CCC 1 .852E-04, .185E-03, .909E-03, .360E-02, .133E-01, .241E-01, 2375
4958 CCC 1 .730E+00, .430E+00, .237E+00, .191E+00, .171E+00, .170E+00, 1650 5023 CCC
4959 CCC 5024 CCC 1 .763E-04, .137E-03, .711E-03, .316E-02, .122E-01, .237E-01, 2400
4960 CCC 1 .149E+01, .506E+00, .294E+00, .238E+00, .210E+00, .201E+00, 1675 5025 CCC
4961 CCC 5026 CCC 1 .615E-04, .126E-03, .610E-03, .257E-02, .101E-01, .218E-01/ 2425
4962 CCC 1 .100E+01, .553E+00, .434E+00, .340E+00, .260E+00, .220E+00, 1700 5027 CCC
4963 CCC 5028 CCC DATA A13/
4964 CCC 1 .802E+00, .658E+00, .528E+00, .411E+00, .300E+00, .240E+00, 1725 5029 CCC
4965 CCC 5030 CCC 1 .480E-04, .113E-03, .518E-03, .201E-02, .920E-02, .200E-01, 2450
4966 CCC 1 .580E+00, .527E+00, .460E+00, .378E+00, .322E+00, .283E+00, 1750 5031 CCC
4967 CCC 5032 CCC 1 .372E-04, .106E-03, .435E-03, .168E-02, .785E-02, .183E-01, 2475
4968 CCC 1 .330E+00, .403E+00, .430E+00, .356E+00, .318E+00, .270E+00, 1775 5033 CCC
4969 CCC 5034 CCC 1 .355E-04, .101E-03, .376E-03, .168E-02, .669E-02, .166E-01, 2500
4970 CCC 1 .250E+00, .393E+00, .405E+00, .342E+00, .301E+00, .275E+00, 1800 5035 CCC
4971 CCC 5036 CCC 1 .358E-04, .990E-04, .366E-03, .167E-02, .651E-02, .156E-01, 2525
4972 CCC 1 .147E+00, .249E+00, .313E+00, .318E+00, .291E+00, .268E+00/ 1825 5037 CCC
4973 CCC 5038 CCC 1 .389E-04, .102E-03, .376E-03, .167E-02, .641E-02, .152E-01, 2550
4974 CCC DATA A10/ 5039 CCC
4975 CCC 5040 CCC 1 .422E-04, .106E-03, .373E-03, .168E-02, .656E-02, .150E-01, 2575
4976 CCC 1 .910E-01, .252E+00, .298E+00, .295E+00, .269E+00, .253E+00, 1850 5041 CCC
4977 CCC 5042 CCC 1 .521E-04, .111E-03, .371E-03, .170E-02, .673E-02, .152E-01, 2600
4978 CCC 1 .580E-01, .158E+00, .214E+00, .244E+00, .244E+00, .245E+00, 1875 5043 CCC
4979 CCC 5044 CCC 1 .646E-04, .121E-03, .384E-03, .179E-02, .798E-02, .179E-01/ 2625
4980 CCC 1 .370E-01, .113E+00, .184E+00, .218E+00, .214E+00, .218E+00, 1900 5045 CCC
4981 CCC 5046 CCC DATA A14/
4982 CCC 1 .244E-01, .118E+00, .156E+00, .188E+00, .195E+00, .200E+00, 1925 5047 CCC
4983 CCC 5048 CCC 1 .742E-04, .129E-03, .479E-03, .201E-02, .788E-02, .175E-01, 2650
4984 CCC 1 .162E-01, .606E-01, .976E-01, .141E+00, .166E+00, .179E+00, 1950 5049 CCC
4985 CCC 5050 CCC 1 .953E-04, .165E-03, .544E-03, .249E-02, .945E-02, .204E-01, 2675
4986 CCC 1 .112E-01, .425E-01, .903E-01, .133E+00, .148E+00, .156E+00, 1975 5051 CCC
4987 CCC 5052 CCC 1 .101E-03, .190E-03, .761E-03, .324E-02, .106E-01, .231E-01, 2700
4988 CCC 1 .780E-02, .400E-01, .765E-01, .112E+00, .129E+00, .137E+00, 2000 5053 CCC
4989 CCC 5054 CCC 1 .147E-03, .272E-03, .892E-03, .441E-02, .125E-01, .257E-01, 2725
4990 CCC 1 .540E-02, .352E-01, .647E-01, .876E-01, .110E+00, .118E+00/ 2025 5055 CCC
4991 CCC 5056 CCC 1 .195E-03, .326E-03, .100E-02, .499E-02, .147E-01, .295E-01, 2750
4992 CCC DATA A11/ 5057 CCC
4993 CCC 5058 CCC 1 .261E-03, .421E-03, .145E-02, .568E-02, .161E-01, .306E-01, 2775
4994 CCC 1 .380E-02, .252E-01, .507E-01, .705E-01, .888E-01, .100E+00, 2050 5059 CCC
4995 CCC 5060 CCC 1 .305E-03, .515E-03, .195E-02, .754E-02, .185E-01, .363E-01, 2800
4996 CCC 1 .260E-02, .179E-01, .377E-01, .546E-01, .724E-01, .828E-01, 2075 5061 CCC
4997 CCC 5062 CCC 1 .362E-03, .645E-03, .237E-02, .830E-02, .205E-01, .373E-01/ 2825
4998 CCC 1 .180E-02, .123E-01, .294E-01, .443E-01, .608E-01, .686E-01, 2100 5063 CCC
4999 CCC 5064 CCC DATA A15/
5000 CCC 1 .127E-02, .850E-02, .212E-01, .378E-01, .579E-01, .640E-01, 2125 5065 CCC
5001 CCC 5066 CCC 1 .507E-03, .850E-03, .274E-02, .888E-02, .234E-01, .431E-01, 2850
5002 CCC 1 .880E-03, .680E-02, .152E-01, .275E-01, .449E-01, .521E-01, 2150 5067 CCC
5003 CCC 5068 CCC 1 .799E-03, .118E-02, .322E-02, .110E-01, .262E-01, .451E-01, 2875
5004 CCC 1 .620E-02, .400E-02, .107E-01, .214E-01, .374E-01, .453E-01, 2175 5069 CCC
5005 CCC 5070 CCC 1 .935E-03, .160E-02, .386E-02, .126E-01, .292E-01, .530E-01, 2900

5071 CCC 5136 CCC DATA A19/

5072 CCC 1 .108E-02, .231E-02, .451E-02, .140E-01, .306E-01, .536E-01, 2925 5137 CCC
5073 CCC 5138 CCC 1 .473E+00, .405E+00, .347E+00, .281E+00, .238E+00, .219E+00, 3650
5074 CCC 1 .192E-02, .271E-02, .563E-02, .159E-01, .357E-01, .629E-01, 2950 5139 CCC
5075 CCC 5140 CCC 1 .568E+00, .501E+00, .423E+00, .315E+00, .243E+00, .218E+00, 3675
5076 CCC 1 .263E-02, .300E-02, .625E-02, .179E-01, .385E-01, .666E-01, 2975 5141 CCC
5077 CCC 5142 CCC 1 .690E+00, .708E+00, .673E+00, .432E+00, .268E+00, .189E+00, 3700
5078 CCC 1 .295E-02, .330E-02, .701E-02, .203E-01, .460E-01, .782E-01, 3000 5143 CCC
5079 CCC 5144 CCC 1 .617E+00, .831E+00, .566E+00, .320E+00, .194E+00, .123E+00, 3725
5080 CCC 1 .310E-02, .370E-02, .846E-02, .220E-01, .519E-01, .889E-01/ 3025 5145 CCC
5081 CCC 5146 CCC 1 .181E+01, .520E+00, .200E+00, .131E+00, .124E+00, .107E+00, 3750
5082 CCC DATA A16/ 5147 CCC
5083 CCC 5148 CCC 1 .136E+00, .124E+00, .120E+00, .119E+00, .115E+00, .115E+00, 3775
5084 CCC 1 .340E-02, .400E-02, .969E-02, .279E-01, .662E-01, .109E+00, 3050 5149 CCC
5085 CCC 5150 CCC 1 .455E+00, .298E+00, .167E+00, .129E+00, .123E+00, .112E+00, 3800
5086 CCC 1 .730E-02, .450E-02, .111E-01, .272E-01, .676E-01, .109E+00, 3075 5151 CCC
5087 CCC 5152 CCC 1 .760E+00, .503E+00, .242E+00, .154E+00, .129E+00, .127E+00/ 3825
5088 CCC 1 .900E-02, .480E-02, .137E-01, .372E-01, .864E-01, .133E+00, 3100 5153 CCC
5089 CCC 5154 CCC DATA A20/
5090 CCC 1 .100E-02, .510E-02, .162E-01, .471E-01, .100E+00, .142E+00, 3125 5155 CCC
5091 CCC 5156 CCC 1 .836E+00, .584E+00, .277E+00, .184E+00, .161E+00, .145E+00, 3850
5092 CCC 1 .640E-03, .550E-02, .205E-01, .530E-01, .122E+00, .168E+00, 3150 5157 CCC
5093 CCC 5158 CCC 1 .840E+00, .728E+00, .422E+00, .236E+00, .197E+00, .167E+00, 3875
5094 CCC 1 .160E-02, .600E-02, .247E-01, .633E-01, .135E+00, .177E+00, 3175 5159 CCC
5095 CCC 5160 CCC 1 .505E+00, .500E+00, .379E+00, .276E+00, .227E+00, .192E+00, 3900
5096 CCC 1 .330E-02, .700E-02, .283E-01, .770E-01, .153E+00, .185E+00, 3200 5161 CCC
5097 CCC 5162 CCC 1 .117E+00, .400E+00, .423E+00, .315E+00, .243E+00, .202E+00, 3925
5098 CCC 1 .410E-02, .860E-02, .376E-01, .914E-01, .166E+00, .206E+00/ 3225 5163 CCC
5099 CCC 5164 CCC 1 .460E-01, .300E+00, .358E+00, .290E+00, .230E+00, .202E+00, 3950
5100 CCC DATA A17/ 5165 CCC
5101 CCC 5166 CCC 1 .183E-01, .205E+00, .269E+00, .235E+00, .195E+00, .192E+00, 3975
5102 CCC 1 .410E-02, .103E-01, .514E-01, .117E+00, .194E+00, .228E+00, 3250 5167 CCC
5103 CCC 5168 CCC 1 .730E-02, .135E+00, .186E+00, .179E+00, .159E+00, .168E+00, 4000
5104 CCC 1 .290E-02, .129E-01, .664E-01, .147E+00, .220E+00, .254E+00, 3275 5169 CCC
5105 CCC 5170 CCC 1 .557E-02, .790E-01, .113E+00, .124E+00, .124E+00, .134E+00/ 4025
5106 CCC 1 .220E-02, .161E-01, .834E-01, .171E+00, .237E+00, .263E+00, 3300 5171 CCC
5107 CCC 5172 CCC DATA A21/
5108 CCC 1 .220E-02, .212E-01, .103E+00, .201E+00, .268E+00, .283E+00, 3325 5173 CCC
5109 CCC 5174 CCC 1 .283E-02, .415E-01, .662E-01, .886E-01, .103E+00, .106E+00, 4050
5110 CCC 1 .250E-02, .285E-01, .135E+00, .240E+00, .295E+00, .295E+00, 3350 5175 CCC
5111 CCC 5176 CCC 1 .226E-02, .197E-01, .367E-01, .594E-01, .801E-01, .879E-01, 4075
5112 CCC 1 .310E-02, .385E-01, .169E+00, .272E+00, .312E+00, .301E+00, 3375 5177 CCC
5113 CCC 5178 CCC 1 .155E-02, .860E-02, .211E-01, .395E-01, .503E-01, .610E-01, 4100
5114 CCC 1 .420E-02, .540E-01, .214E+00, .309E+00, .329E+00, .307E+00, 3400 5179 CCC
5115 CCC 5180 CCC 1 .103E-02, .521E-02, .119E-01, .246E-01, .354E-01, .480E-01, 4125
5116 CCC 1 .600E-02, .770E-01, .267E+00, .343E+00, .332E+00, .314E+00/ 3425 5181 CCC
5117 CCC 5182 CCC 1 .821E-03, .365E-02, .759E-02, .166E-01, .258E-01, .370E-01, 4150
5118 CCC DATA A18/ 5183 CCC
5119 CCC 5184 CCC 1 .752E-03, .183E-02, .445E-02, .100E-01, .179E-01, .268E-01, 4175
5120 CCC 1 .940E-02, .117E+00, .333E+00, .372E+00, .344E+00, .303E+00, 3450 5185 CCC
5121 CCC 5186 CCC 1 .429E-03, .141E-02, .354E-02, .821E-02, .142E-01, .212E-01, 4200
5122 CCC 1 .165E-01, .173E+00, .365E+00, .385E+00, .353E+00, .300E+00, 3475 5187 CCC
5123 CCC 5188 CCC 1 .327E-03, .902E-03, .209E-02, .588E-02, .112E-01, .172E-01/ 4225
5124 CCC 1 .360E-01, .258E+00, .438E+00, .393E+00, .315E+00, .288E+00, 3500 5189 CCC
5125 CCC 5190 CCC END
5126 CCC 1 .720E-01, .375E+00, .510E+00, .409E+00, .294E+00, .271E+00, 3525 5191 CCC
5127 CCC 5192 CCC
5128 CCC 1 .133E+00, .401E+00, .499E+00, .390E+00, .281E+00, .257E+00, 3550 5193 CCC BLOCK DATA BD2
5129 CCC 5194 CCC
5130 CCC 1 .215E+00, .500E+00, .443E+00, .341E+00, .254E+00, .230E+00, 3575 5195 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
5131 CCC 5196 CCC
5132 CCC 1 .318E+00, .450E+00, .346E+00, .286E+00, .245E+00, .219E+00, 3600 5197 CCC COMMON/CH2O/SD(6,376)
5133 CCC 5198 CCC
5134 CCC 1 .442E+00, .400E+00, .354E+00, .279E+00, .233E+00, .216E+00/ 3625 5199 CCC DIMENSION A22(6,8),A23(6,8),A24(6,8),A25(6,8),A26(6,8),A27(6,8),
5135 CCC 5200 CCC
5201 CCC 4A28(6,8), 5266 CCC
5202 CCC 5267 CCC DATA A24/
5203 CCC 5A29(6,8),A30(6,8),A31(6,8),A32(6,8),A33(6,8),A34(6,8),A35(6,8), 5268 CCC
5204 CCC 5269 CCC 1 .219E-04, .722E-04, .297E-03, .169E-02, .783E-02, .197E-01, 4650
5205 CCC 6A36(6,8),A37(6,8),A38(6,8),A39(6,8),A40(6,8),A41(6,8),A42(6,8), 5270 CCC
5206 CCC 5271 CCC 1 .226E-04, .771E-04, .341E-03, .236E-02, .925E-02, .226E-01, 4675
5207 CCC 7A43(6,8),A44(6,8),A45(6,8),A46(6,8),A47(6,8) 5272 CCC
5208 CCC 5273 CCC 1 .250E-04, .815E-04, .387E-03, .286E-02, .106E-01, .250E-01, 4700
5209 CCC EQUIVALENCE(A22(1,1),SD(1,169)),(A23(1,1),SD(1,177)),(A24(1,1) 5274 CCC
5210 CCC 5275 CCC 1 .280E-04, .845E-04, .420E-03, .357E-02, .124E-01, .276E-01, 4725
5211 CCC 1,SD(1,185)),(A25(1,1),SD(1,193)),(A26(1,1),SD(1,201)),(A27(1,1) 5276 CCC
5212 CCC 5277 CCC 1 .351E-04, .192E-03, .470E-03, .467E-02, .166E-01, .313E-01, 4750
5213 CCC 2,SD(1,209)),(A28(1,1),SD(1,217)),(A29(1,1),SD(1,225)),(A30(1,1) 5278 CCC
5214 CCC 5279 CCC 1 .435E-04, .200E-03, .105E-02, .566E-02, .185E-01, .341E-01, 4775
5215 CCC 3,SD(1,233)),(A31(1,1),SD(1,241)),(A32(1,1),SD(1,249)),(A33(1,1) 5280 CCC
5216 CCC 5281 CCC 1 .522E-04, .233E-03, .129E-02, .736E-02, .229E-01, .378E-01, 4800
5217 CCC 4,SD(1,257)),(A34(1,1),SD(1,265)),(A35(1,1),SD(1,273)),(A36(1,1) 5282 CCC
5218 CCC 5283 CCC 1 .673E-04, .306E-03, .183E-02, .982E-02, .258E-01, .404E-01/ 4825
5219 CCC 5,SD(1,281)),(A37(1,1),SD(1,289)),(A38(1,1),SD(1,297)) 5284 CCC
5220 CCC 5285 CCC DATA A25/
5221 CCC EQUIVALENCE(A39(1,1),SD(1,305)),(A40(1,1),SD(1,313)),(A41(1,1) 5286 CCC
5222 CCC 5287 CCC 1 .886E-04, .399E-03, .246E-02, .128E-01, .302E-01, .430E-01, 4850
5223 CCC 1,SD(1,321)),(A42(1,1),SD(1,329)),(A43(1,1),SD(1,337)),(A44(1,1) 5288 CCC
5224 CCC 5289 CCC 1 .113E-03, .618E-03, .346E-02, .161E-01, .358E-01, .459E-01, 4875
5225 CCC 2,SD(1,345)),(A45(1,1),SD(1,353)),(A46(1,1),SD(1,361)),(A47(1,1) 5290 CCC
5226 CCC 5291 CCC 1 .174E-03, .825E-03, .441E-02, .200E-01, .417E-01, .493E-01, 4900
5227 CCC 3,SD(1,369)) 5292 CCC
5228 CCC 5293 CCC 1 .265E-03, .163E-02, .777E-02, .245E-01, .450E-01, .507E-01, 4925
5229 CCCC TEMP,K= 300 600 1000 1500 2000 2500 WAVE NO. 5294 CCC
5230 CCC 5295 CCC 1 .355E-03, .200E-02, .978E-02, .317E-01, .492E-01, .527E-01, 4950
5231 CCC DATA A22/ 5296 CCC
5232 CCC 5297 CCC 1 .538E-03, .271E-02, .167E-01, .401E-01, .503E-01, .523E-01, 4975
5233 CCC 1 .225E-03, .685E-03, .189E-02, .512E-02, .101E-01, .164E-01, 4250 5298 CCC
5234 CCC 5299 CCC 1 .651E-03, .301E-02, .264E-01, .467E-01, .520E-01, .526E-01, 5000
5235 CCC 1 .186E-03, .551E-03, .156E-02, .366E-02, .812E-02, .136E-01, 4275 5300 CCC
5236 CCC 5301 CCC 1 .987E-03, .530E-02, .321E-01, .499E-01, .523E-01, .510E-01/ 5025
5237 CCC 1 .173E-03, .472E-03, .139E-02, .306E-02, .661E-02, .115E-01, 4300 5302 CCC
5238 CCC 5303 CCC DATA A26/
5239 CCC 1 .138E-03, .395E-03, .110E-02, .272E-02, .587E-02, .104E-01, 4325 5304 CCC
5240 CCC 5305 CCC 1 .135E-02, .860E-02, .389E-01, .528E-01, .513E-01, .492E-01, 5050
5241 CCC 1 .900E-04, .270E-03, .968E-03, .222E-02, .497E-02, .921E-02, 4350 5306 CCC
5242 CCC 5307 CCC 1 .226E-02, .130E-01, .472E-01, .559E-01, .500E-01, .469E-01, 5075
5243 CCC 1 .752E-04, .233E-03, .744E-03, .208E-02, .466E-02, .876E-02, 4375 5308 CCC
5244 CCC 5309 CCC 1 .431E-02, .198E-01, .526E-01, .557E-01, .480E-01, .452E-01, 5100
5245 CCC 1 .618E-04, .175E-03, .638E-03, .185E-02, .465E-02, .914E-02, 4400 5310 CCC
5246 CCC 5311 CCC 1 .628E-02, .282E-01, .488E-01, .495E-01, .451E-01, .430E-01, 5125
5247 CCC 1 .504E-04, .134E-03, .499E-03, .174E-02, .455E-02, .935E-02/ 4425 5312 CCC
5248 CCC 5313 CCC 1 .900E-02, .390E-01, .471E-01, .449E-01, .430E-01, .423E-01, 5150
5249 CCC DATA A23/ 5314 CCC
5250 CCC 5315 CCC 1 .180E-01, .462E-01, .412E-01, .391E-01, .403E-01, .415E-01, 5175
5251 CCC 1 .375E-04, .123E-03, .485E-03, .182E-02, .456E-02, .971E-02, 4450 5316 CCC
5252 CCC 5317 CCC 1 .348E-01, .710E-01, .402E-01, .360E-01, .384E-01, .414E-01, 5200
5253 CCC 1 .305E-04, .892E-04, .338E-03, .134E-02, .460E-02, .104E-01, 4475 5318 CCC
5254 CCC 5319 CCC 1 .718E-01, .590E-01, .399E-01, .360E-01, .376E-01, .420E-01/ 5225
5255 CCC 1 .257E-04, .790E-04, .329E-03, .154E-02, .477E-02, .112E-01, 4500 5320 CCC
5256 CCC 5321 CCC DATA A27/
5257 CCC 1 .242E-04, .740E-04, .308E-03, .135E-02, .497E-02, .122E-01, 4525 5322 CCC
5258 CCC 5323 CCC 1 .111E+00, .368E-01, .340E-01, .369E-01, .409E-01, .454E-01, 5250
5259 CCC 1 .215E-04, .653E-04, .282E-03, .131E-02, .521E-02, .133E-01, 4550 5324 CCC
5260 CCC 5325 CCC 1 .329E-01, .285E-01, .365E-01, .423E-01, .461E-01, .482E-01, 5275
5261 CCC 1 .218E-04, .660E-04, .272E-03, .152E-02, .573E-02, .148E-01, 4575 5326 CCC
5262 CCC 5327 CCC 1 .281E-01, .270E-01, .432E-01, .505E-01, .529E-01, .511E-01, 5300
5263 CCC 1 .215E-04, .671E-04, .268E-03, .134E-02, .607E-02, .159E-01, 4600 5328 CCC
5264 CCC 5329 CCC 1 .121E+00, .422E-01, .589E-01, .598E-01, .572E-01, .544E-01, 5325
5265 CCC 1 .217E-04, .695E-04, .285E-03, .161E-02, .677E-02, .173E-01/ 4625 5330 CCC

5331 CCC 1 .139E+00, .105E+00, .844E-01, .687E-01, .593E-01, .560E-01, 5350 5396 CCC
5332 CCC 5397 CCC 1 .988E-05, .420E-04, .210E-03, .832E-03, .317E-02, .842E-02, 6075
5333 CCC 1 .774E-01, .710E-01, .683E-01, .618E-01, .556E-01, .534E-01, 5375 5398 CCC
5334 CCC 5399 CCC 1 .991E-05, .425E-04, .219E-03, .877E-03, .340E-02, .888E-02, 6100
5335 CCC 1 .858E-01, .483E-01, .579E-01, .547E-01, .503E-01, .495E-01, 5400 5400 CCC
5336 CCC 5401 CCC 1 .102E-04, .435E-04, .231E-03, .937E-03, .361E-02, .929E-02, 6125
5337 CCC 1 .985E-01, .575E-01, .589E-01, .510E-01, .451E-01, .449E-01/ 5425 5402 CCC
5338 CCC 5403 CCC 1 .110E-04, .486E-04, .244E-03, .971E-03, .402E-02, .994E-02, 6150
5339 CCC DATA A28/ 5404 CCC
5340 CCC 5405 CCC 1 .127E-04, .579E-04, .257E-03, .111E-02, .437E-02, .104E-01, 6175
5341 CCC 1 .996E-01, .682E-01, .539E-01, .489E-01, .454E-01, .446E-01, 5450 5406 CCC
5342 CCC 5407 CCC 1 .131E-04, .612E-04, .277E-03, .113E-02, .465E-02, .110E-01, 6200
5343 CCC 1 .680E-01, .680E-01, .548E-01, .495E-01, .460E-01, .458E-01, 5475 5408 CCC
5344 CCC 5409 CCC 1 .150E-04, .783E-04, .353E-03, .116E-02, .510E-02, .116E-01/ 6225
5345 CCC 1 .325E-01, .520E-01, .515E-01, .483E-01, .449E-01, .454E-01, 5500 5410 CCC
5346 CCC 5411 CCC DATA A32/
5347 CCC 1 .150E-01, .350E-01, .451E-01, .464E-01, .452E-01, .449E-01, 5525 5412 CCC
5348 CCC 5413 CCC 1 .178E-04, .922E-04, .394E-03, .157E-02, .555E-02, .123E-01, 6250
5349 CCC 1 .620E-02, .238E-01, .369E-01, .408E-01, .414E-01, .417E-01, 5550 5414 CCC
5350 CCC 5415 CCC 1 .203E-04, .115E-03, .481E-03, .188E-02, .601E-02, .131E-01, 6275
5351 CCC 1 .270E-02, .158E-01, .282E-01, .339E-01, .366E-01, .384E-01, 5575 5416 CCC
5352 CCC 5417 CCC 1 .230E-04, .145E-03, .617E-03, .183E-02, .644E-02, .139E-01, 6300
5353 CCC 1 .113E-02, .101E-01, .203E-01, .263E-01, .303E-01, .333E-01, 5600 5418 CCC
5354 CCC 5419 CCC 1 .280E-04, .187E-03, .723E-03, .202E-02, .686E-02, .146E-01, 6325
5355 CCC 1 .829E-03, .590E-02, .148E-01, .206E-01, .247E-01, .295E-01/ 5625 5420 CCC
5356 CCC 5421 CCC 1 .305E-04, .209E-03, .811E-03, .243E-02, .779E-02, .157E-01, 6350
5357 CCC DATA A29/ 5422 CCC
5358 CCC 5423 CCC 1 .455E-04, .244E-03, .935E-03, .243E-02, .844E-02, .166E-01, 6375
5359 CCC 1 .365E-03, .310E-02, .969E-02, .154E-01, .203E-01, .258E-01, 5650 5424 CCC
5360 CCC 5425 CCC 1 .661E-04, .320E-03, .989E-03, .288E-02, .902E-02, .173E-01, 6400
5361 CCC 1 .240E-03, .130E-02, .589E-02, .112E-01, .164E-01, .222E-01, 5675 5426 CCC
5362 CCC 5427 CCC 1 .723E-04, .397E-03, .122E-02, .359E-02, .100E-01, .184E-01/ 6425
5363 CCC 1 .158E-03, .400E-03, .417E-02, .850E-02, .134E-01, .190E-01, 5700 5428 CCC
5364 CCC 5429 CCC DATA A33/
5365 CCC 1 .103E-03, .262E-03, .208E-02, .594E-02, .109E-01, .162E-01, 5725 5430 CCC
5366 CCC 5431 CCC 1 .847E-04, .481E-03, .143E-02, .429E-02, .108E-01, .192E-01, 6450
5367 CCC 1 .741E-04, .181E-03, .142E-02, .455E-02, .907E-02, .141E-01, 5750 5432 CCC
5368 CCC 5433 CCC 1 .103E-03, .591E-03, .174E-02, .488E-02, .116E-01, .200E-01, 6475
5369 CCC 1 .625E-04, .135E-03, .816E-03, .316E-02, .698E-02, .121E-01, 5775 5434 CCC
5370 CCC 5435 CCC 1 .131E-03, .703E-03, .247E-02, .549E-02, .124E-01, .205E-01, 6500
5371 CCC 1 .499E-04, .111E-03, .624E-03, .230E-02, .551E-02, .102E-01, 5800 5436 CCC
5372 CCC 5437 CCC 1 .165E-03, .872E-03, .265E-02, .641E-02, .131E-01, .211E-01, 6525
5373 CCC 1 .325E-04, .677E-04, .425E-03, .124E-02, .385E-02, .818E-02/ 5825 5438 CCC
5374 CCC 5439 CCC 1 .205E-03, .110E-02, .298E-02, .749E-02, .140E-01, .218E-01, 6550
5375 CCC DATA A30/ 5440 CCC
5376 CCC 5441 CCC 1 .253E-03, .130E-02, .346E-02, .811E-02, .150E-01, .230E-01, 6575
5377 CCC 1 .231E-04, .563E-04, .278E-03, .986E-03, .290E-02, .672E-02, 5850 5442 CCC
5378 CCC 5443 CCC 1 .338E-03, .150E-02, .445E-02, .890E-02, .159E-01, .237E-01, 6600
5379 CCC 1 .165E-04, .481E-04, .247E-03, .944E-03, .253E-02, .612E-02, 5875 5444 CCC
5380 CCC 5445 CCC 1 .437E-03, .170E-02, .491E-02, .107E-01, .170E-01, .245E-01/ 6625
5381 CCC 1 .126E-04, .432E-04, .241E-03, .886E-03, .220E-02, .582E-02, 5900 5446 CCC
5382 CCC 5447 CCC DATA A34/
5383 CCC 1 .118E-04, .420E-04, .235E-03, .847E-03, .209E-02, .571E-02, 5925 5448 CCC
5384 CCC 5449 CCC 1 .581E-03, .190E-02, .537E-02, .116E-01, .179E-01, .254E-01, 6650
5385 CCC 1 .110E-04, .408E-04, .226E-03, .812E-03, .221E-02, .604E-02, 5950 5450 CCC
5386 CCC 5451 CCC 1 .685E-03, .220E-02, .578E-02, .128E-01, .189E-01, .263E-01, 6675
5387 CCC 1 .101E-04, .400E-04, .213E-03, .805E-03, .239E-02, .641E-02, 5975 5452 CCC
5388 CCC 5453 CCC 1 .900E-03, .250E-02, .649E-02, .134E-01, .195E-01, .275E-01, 6700
5389 CCC 1 .983E-05, .395E-04, .186E-03, .801E-03, .247E-02, .691E-02, 6000 5454 CCC
5390 CCC 5455 CCC 1 .121E-02, .280E-02, .722E-02, .142E-01, .202E-01, .281E-01, 6725
5391 CCC 1 .979E-05, .401E-04, .193E-03, .805E-03, .260E-02, .732E-02/ 6025 5456 CCC
5392 CCC 5457 CCC 1 .152E-02, .330E-02, .813E-02, .161E-01, .212E-01, .288E-01, 6750
5393 CCC DATA A31/ 5458 CCC
5394 CCC 5459 CCC 1 .185E-02, .370E-02, .907E-02, .168E-01, .222E-01, .292E-01, 6775
5395 CCC 1 .976E-05, .410E-04, .201E-03, .814E-03, .285E-02, .776E-02, 6050 5460 CCC
5461 CCC 1 .220E-02, .430E-02, .929E-02, .183E-01, .233E-01, .294E-01, 6800 5526 CCC
5462 CCC 5527 CCC 1 .772E-03, .751E-03, .384E-02, .575E-02, .537E-02, .594E-02, 7525
5463 CCC 1 .255E-02, .500E-02, .114E-01, .195E-01, .245E-01, .289E-01/ 6825 5528 CCC
5464 CCC 5529 CCC 1 .491E-03, .600E-03, .301E-02, .453E-02, .380E-02, .434E-02, 7550
5465 CCC DATA A35/ 5530 CCC
5466 CCC 5531 CCC 1 .275E-03, .410E-03, .193E-02, .366E-02, .319E-02, .332E-02, 7575
5467 CCC 1 .290E-02, .580E-02, .167E-01, .215E-01, .260E-01, .291E-01, 6850 5532 CCC
5468 CCC 5533 CCC 1 .185E-01, .280E-03, .131E-02, .232E-02, .247E-02, .256E-02, 7600
5469 CCC 1 .320E-02, .670E-02, .208E-01, .237E-01, .274E-01, .293E-01, 6875 5534 CCC
5470 CCC 5535 CCC 1 .101E-03, .160E-03, .915E-03, .150E-02, .186E-02, .197E-02/ 7625
5471 CCC 1 .360E-02, .880E-02, .220E-01, .253E-01, .282E-01, .300E-01, 6900 5536 CCC
5472 CCC 5537 CCC DATA A39/
5473 CCC 1 .400E-02, .920E-02, .238E-01, .273E-01, .290E-01, .304E-01, 6925 5538 CCC
5474 CCC 5539 CCC 1 .691E-04, .110E-03, .565E-03, .114E-02, .205E-02, .192E-02, 7650
5475 CCC 1 .460E-02, .108E-01, .272E-01, .279E-01, .298E-01, .310E-01, 6950 5540 CCC
5476 CCC 5541 CCC 1 .476E-04, .750E-04, .114E-02, .124E-02, .175E-02, .187E-02, 7675
5477 CCC 1 .530E-02, .128E-01, .304E-01, .292E-01, .297E-01, .312E-01, 6975 5542 CCC
5478 CCC 5543 CCC 1 .305E-04, .590E-04, .529E-03, .114E-02, .160E-02, .185E-02, 7700
5479 CCC 1 .620E-02, .152E-01, .344E-01, .303E-01, .293E-01, .310E-01, 7000 5544 CCC
5480 CCC 5545 CCC 1 .240E-04, .480E-04, .293E-03, .842E-03, .141E-02, .184E-02, 7725
5481 CCC 1 .760E-02, .182E-01, .341E-01, .297E-01, .290E-01, .300E-01/ 7025 5546 CCC
5482 CCC 5547 CCC 1 .170E-04, .360E-04, .122E-03, .435E-03, .124E-02, .182E-02, 7750
5483 CCC DATA A36/ 5548 CCC
5484 CCC 5549 CCC 1 .120E-04, .240E-04, .121E-03, .435E-03, .118E-02, .187E-02, 7775
5485 CCC 1 .980E-02, .222E-01, .398E-01, .318E-01, .291E-01, .294E-01, 7050 5550 CCC
5486 CCC 5551 CCC 1 .810E-05, .170E-04, .103E-03, .439E-03, .126E-02, .192E-02, 7800
5487 CCC 1 .132E-01, .271E-01, .402E-01, .294E-01, .274E-01, .282E-01, 7075 5552 CCC
5488 CCC 5553 CCC 1 .550E-05, .120E-04, .866E-04, .367E-03, .119E-02, .193E-02/ 7825
5489 CCC 1 .190E-01, .335E-01, .421E-01, .286E-01, .262E-01, .269E-01, 7100 5554 CCC
5490 CCC 5555 CCC DATA A40/
5491 CCC 1 .240E-01, .432E-01, .431E-01, .276E-01, .245E-01, .257E-01, 7125 5556 CCC
5492 CCC 5557 CCC 1 .390E-05, .900E-05, .716E-04, .351E-03, .116E-02, .194E-02, 7850
5493 CCC 1 .288E-01, .570E-01, .458E-01, .270E-01, .228E-01, .243E-01, 7150 5558 CCC
5494 CCC 5559 CCC 1 .295E-05, .830E-05, .373E-04, .254E-03, .114E-02, .196E-02, 7875
5495 CCC 1 .323E-01, .740E-01, .449E-01, .261E-01, .214E-01, .221E-01, 7175 5560 CCC
5496 CCC 5561 CCC 1 .230E-05, .800E-05, .465E-04, .298E-03, .117E-02, .201E-02, 7900
5497 CCC 1 .570E-01, .890E-01, .435E-01, .225E-01, .199E-01, .196E-01, 7200 5562 CCC
5498 CCC 5563 CCC 1 .225E-05, .820E-05, .367E-04, .252E-03, .116E-02, .205E-02, 7925
5499 CCC 1 .216E-01, .680E-01, .378E-01, .239E-01, .195E-01, .192E-01/ 7225 5564 CCC
5500 CCC 5565 CCC 1 .220E-05, .840E-05, .371E-04, .268E-03, .127E-02, .211E-02, 7950
5501 CCC DATA A37/ 5566 CCC
5502 CCC 5567 CCC 1 .223E-05, .920E-05, .396E-04, .273E-03, .128E-02, .216E-02, 7975
5503 CCC 1 .126E-01, .475E-01, .364E-01, .238E-01, .197E-01, .192E-01, 7250 5568 CCC
5504 CCC 5569 CCC 1 .235E-05, .103E-04, .415E-04, .263E-03, .121E-02, .221E-02, 8000
5505 CCC 1 .117E-01, .369E-01, .385E-01, .249E-01, .212E-01, .204E-01, 7275 5570 CCC
5506 CCC 5571 CCC 1 .280E-05, .125E-04, .633E-04, .363E-03, .136E-02, .231E-02/ 8025
5507 CCC 1 .140E-01, .370E-01, .419E-01, .272E-01, .228E-01, .213E-01, 7300 5572 CCC
5508 CCC 5573 CCC DATA A41/
5509 CCC 1 .425E-01, .418E-01, .440E-01, .280E-01, .248E-01, .229E-01, 7325 5574 CCC
5510 CCC 5575 CCC 1 .310E-05, .150E-04, .979E-04, .492E-03, .150E-02, .241E-02, 8050
5511 CCC 1 .640E-01, .460E-01, .427E-01, .290E-01, .263E-01, .238E-01, 7350 5576 CCC
5512 CCC 5577 CCC 1 .370E-05, .180E-04, .120E-03, .580E-03, .167E-02, .251E-02, 8075
5513 CCC 1 .385E-01, .385E-01, .374E-01, .259E-01, .235E-01, .224E-01, 7375 5578 CCC
5514 CCC 5579 CCC 1 .420E-05, .200E-04, .987E-04, .509E-03, .171E-02, .257E-02, 8100
5515 CCC 1 .182E-01, .179E-01, .282E-01, .231E-01, .211E-01, .214E-01, 7400 5580 CCC
5516 CCC 5581 CCC 1 .510E-05, .240E-04, .134E-03, .547E-03, .173E-02, .267E-02, 8125
5517 CCC 1 .170E-01, .810E-02, .191E-01, .175E-01, .181E-01, .194E-01/ 7425 5582 CCC
5518 CCC 5583 CCC 1 .600E-05, .270E-04, .121E-03, .534E-03, .172E-02, .274E-02, 8150
5519 CCC DATA A38/ 5584 CCC
5520 CCC 5585 CCC 1 .720E-05, .300E-04, .204E-03, .684E-03, .184E-02, .285E-02, 8175
5521 CCC 1 .161E-01, .370E-02, .105E-01, .127E-01, .152E-01, .171E-01, 7450 5586 CCC
5522 CCC 5587 CCC 1 .820E-05, .330E-04, .276E-03, .819E-03, .199E-02, .297E-02, 8200
5523 CCC 1 .145E-01, .170E-02, .554E-02, .855E-02, .113E-01, .131E-01, 7475 5588 CCC
5524 CCC 5589 CCC 1 .100E-04, .380E-04, .317E-03, .859E-03, .214E-02, .308E-02/ 8225
5525 CCC 1 .175E-02, .140E-02, .385E-02, .595E-02, .803E-02, .945E-02, 7500 5590 CCC

5591 CCC DATA A42/ 5656 CCC

5592 CCC 5657 CCC 1 .510E-05, .110E-04, .120E-03, .629E-03, .177E-02, .203E-02, 8975
5593 CCC 1 .125E-04, .420E-04, .240E-03, .818E-03, .220E-02, .317E-02, 8250 5658 CCC
5594 CCC 5659 CCC 1 .460E-05, .950E-05, .960E-04, .513E-03, .154E-02, .180E-02, 9000
5595 CCC 1 .145E-04, .500E-04, .452E-03, .109E-02, .238E-02, .293E-02, 8275 5660 CCC
5596 CCC 5661 CCC 1 .420E-05, .800E-05, .578E-04, .314E-03, .123E-02, .154E-02/ 9025
5597 CCC 1 .175E-04, .560E-04, .301E-03, .941E-03, .243E-02, .342E-02, 8300 5662 CCC
5598 CCC 5663 CCC DATA A46/
5599 CCC 1 .198E-04, .630E-04, .280E-03, .107E-02, .260E-02, .353E-02, 8325 5664 CCC
5600 CCC 5665 CCC 1 .380E-05, .720E-05, .529E-04, .292E-03, .114E-02, .137E-02, 9050
5601 CCC 1 .230E-04, .710E-04, .276E-03, .109E-02, .272E-02, .365E-02, 8350 5666 CCC
5602 CCC 5667 CCC 1 .330E-05, .660E-05, .485E-04, .269E-03, .102E-02, .122E-02, 9075
5603 CCC 1 .280E-04, .830E-04, .369E-03, .127E-02, .295E-02, .377E-02, 8375 5668 CCC
5604 CCC 5669 CCC 1 .290E-05, .580E-05, .430E-04, .239E-03, .896E-03, .107E-02, 9100
5605 CCC 1 .330E-04, .890E-04, .430E-03, .139E-02, .306E-02, .385E-02, 8400 5670 CCC
5606 CCC 5671 CCC 1 .270E-05, .520E-05, .259E-04, .193E-03, .748E-03, .944E-03, 9125
5607 CCC 1 .360E-04, .950E-04, .371E-03, .135E-02, .306E-02, .384E-02/ 8425 5672 CCC
5608 CCC 5673 CCC 1 .240E-05, .450E-05, .316E-04, .207E-03, .671E-02, .848E-03, 9150
5609 CCC DATA A43/ 5674 CCC
5610 CCC 5675 CCC 1 .220E-05, .400E-05, .444E-05, .602E-04, .516E-03, .750E-03, 9175
5611 CCC 1 .390E-04, .980E-04, .434E-03, .147E-02, .316E-02, .385E-02, 8450 5676 CCC
5612 CCC 5677 CCC 1 .190E-05, .360E-05, .324E-05, .460E-04, .439E-03, .688E-03, 9200
5613 CCC 1 .400E-04, .990E-04, .397E-03, .143E-02, .318E-02, .384E-02, 8475 5678 CCC
5614 CCC 5679 CCC 1 .170E-05, .320E-05, .180E-05, .321E-04, .384E-03, .653E-03/ 9225
5615 CCC 1 .400E-04, .980E-04, .364E-03, .141E-02, .317E-02, .381E-02, 8500 5680 CCC
5616 CCC 5681 CCC DATA A47/
5617 CCC 1 .390E-04, .940E-04, .390E-03, .142E-02, .314E-02, .376E-02, 8525 5682 CCC
5618 CCC 5683 CCC 1 .140E-05, .280E-05, .171E-05, .344E-04, .340E-03, .616E-03, 9250
5619 CCC 1 .380E-04, .900E-04, .380E-03, .145E-02, .318E-02, .375E-02, 8550 5684 CCC
5620 CCC 5685 CCC 1 .130E-05, .250E-05, .299E-05, .600E-04, .343E-03, .619E-03, 9275
5621 CCC 1 .380E-04, .900E-04, .380E-03, .145E-02, .318E-02, .375E-02, 8575 5686 CCC
5622 CCC 5687 CCC 1 .120E-05, .220E-05, .299E-05, .600E-04, .343E-03, .619E-03, 9300
5623 CCC 1 .330E-04, .750E-04, .358E-03, .138E-02, .310E-02, .372E-02, 8600 5688 CCC
5624 CCC 5689 CCC 1 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1.,
5625 CCC 1 .270E-04, .580E-04, .382E-03, .143E-02, .315E-02, .369E-02/ 8625 5690 CCC
5626 CCC 5691 CCC 1 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1./
5627 CCC DATA A44/ 5692 CCC
5628 CCC 5693 CCC END
5629 CCC 1 .240E-04, .500E-04, .343E-03, .136E-02, .306E-02, .363E-02, 8650 5694 CCC
5630 CCC 5695 CCC
5631 CCC 1 .200E-04, .450E-04, .309E-03, .134E-02, .306E-02, .359E-02, 8675 5696 CCC
5632 CCC 5697 CCC BLOCK DATA BD3
5633 CCC 1 .180E-04, .400E-04, .281E-03, .127E-02, .294E-02, .341E-02, 8700 5698 CCC
5634 CCC 5699 CCC IMPLICIT DOUBLE PRECISION (A-H, O-Z), INTEGER (I-N)
5635 CCC 1 .170E-04, .360E-04, .276E-03, .124E-02, .290E-02, .336E-02, 8725 5700 CCC
5636 CCC 5701 CCC COMMON/CCO2/SD15(6,80)
5637 CCC 1 .160E-04, .310E-04, .272E-03, .122E-02, .283E-02, .323E-02, 8750 5702 CCC
5638 CCC 5703 CCC COMMON/CCH4/SD7(3,16),SD3(3,32)
5639 CCC 1 .140E-04, .280E-04, .241E-03, .117E-02, .273E-02, .309E-02, 8775 5704 CCC
5640 CCC 5705 CCC COMMON/CPARAM/GAMMA(4,7)
5641 CCC 1 .120E-04, .250E-04, .237E-03, .115E-02, .269E-02, .297E-02, 8800 5706 CCC
5642 CCC 5707 CCC DIMENSION B1(6,8),B2(6,8),B3(6,8),B4(6,8),B5(6,8),
5643 CCC 1 .100E-04, .220E-04, .218E-03, .111E-02, .259E-02, .284E-02/ 8825 5708 CCC
5644 CCC 5709 CCC 1B6(6,8),B7(6,8),B8(6,8),B9(6,8),B10(6,8)
5645 CCC DATA A45/ 5710 CCC
5646 CCC 5711 CCC DIMENSION C1(3,8),C2(3,8),C3(3,8),C4(3,8),C5(3,8),C6(3,8)
5647 CCC 1 .920E-05, .198E-04, .206E-03, .105E-02, .246E-02, .269E-02, 8850 5712 CCC
5648 CCC 5713 CCC EQUIVALENCE(B1(1,1),SD15(1,1)),(B2(1,1),SD15(1,9)),(B3(1,1),
5649 CCC 1 .810E-05, .170E-04, .205E-03, .100E-02, .235E-02, .257E-02, 8875 5714 CCC
5650 CCC 5715 CCC 1SD15(1,17)),(B4(1,1),SD15(1,25)),(B5(1,1),SD15(1,33)),
5651 CCC 1 .720E-05, .160E-04, .177E-03, .921E-03, .220E-02, .245E-02, 8900 5716 CCC
5652 CCC 5717 CCC 2(B6(1,1),SD15(1,41)),(B7(1,1),SD15(1,49)),(B8(1,1),SD15(1,57))
5653 CCC 1 .650E-05, .150E-04, .172E-03, .834E-03, .205E-02, .232E-02, 8925 5718 CCC
5654 CCC 5719 CCC 3,(B9(1,1),SD15(1,65)),(B10(1,1),SD15(1,73))
5655 CCC 1 .590E-05, .130E-04, .147E-03, .735E-03, .194E-02, .218E-02, 8950 5720 CCC
5721 CCC EQUIVALENCE(C1(1,1),SD7(1,1)),(C2(1,1),SD7(1,9)), 5786 CCC
5722 CCC 5787 CCC 1 .000E+00, .750E-02, .690E-01, .140E+00, .225E+00, .340E+00, 570
5723 CCC 1(C3(1,1),SD3(1,1)),(C4(1,1),SD3(1,9)),(C5(1,1),SD3(1,17)), 5788 CCC
5724 CCC 5789 CCC 1 .000E+00, .205E-01, .820E-01, .145E+00, .236E+00, .530E+00/ 575
5725 CCC 2(C6(1,1),SD3(1,25)) 5790 CCC
5726 CCC 5791 CCC DATA B3/
5727 CCC DATA GAMMA/ 5792 CCC
5728 CCC 5793 CCC 1 .000E+00, .355E-01, .117E+00, .193E+00, .295E+00, .550E+00, 580
5729 CCCC LINE BROADENING PARAMETERS,GAMMA(I,J), 5794 CCC
5730 CCC 5795 CCC 1 .157E-01, .520E-01, .170E+00, .235E+00, .305E+00, .410E+00, 585
5731 CCCC J=CO2,H2O,CH4,CO,O2,N2,SELF RESONANT. 5796 CCC
5732 CCC 5797 CCC 1 .150E-01, .880E-01, .270E+00, .330E+00, .440E+00, .520E+00, 590
5733 CCCC I= CO2 H2O CH4 CO 5798 CCC
5734 CCC 5799 CCC 1 .510E-01, .130E+00, .400E+00, .530E+00, .560E+00, .540E+00, 595
5735 CCCC J 5800 CCC
5736 CCC 5801 CCC 1 .120E+00, .165E+00, .275E+00, .320E+00, .420E+00, .560E+00, 600
5737 CCC 1 .09 , .12, .0 , .07, 5802 CCC
5738 CCC 5803 CCC 1 .880E-01, .190E+00, .430E+00, .540E+00, .620E+00, .680E+00, 605
5739 CCC 2 .07 , .09, .0 , .06, 5804 CCC
5740 CCC 5805 CCC 1 .110E+00, .350E+00, .710E+00, .760E+00, .760E+00, .690E+00, 610
5741 CCC 3 .0 , .0 , .16, .0 , 5806 CCC
5742 CCC 5807 CCC 1 .180E+00, .470E+00, .920E+00, .970E+00, .910E+00, .670E+00/ 615
5743 CCC 4 .06 , .10, .0 , .06, 5808 CCC
5744 CCC 5809 CCC DATA B4/
5745 CCC 5 .055, .04, .0 , .05, 5810 CCC
5746 CCC 5811 CCC 1 .970E-01, .265E+00, .610E+00, .720E+00, .780E+00, .730E+00, 620
5747 CCC 6 .07 , .09, .0 , .06, 5812 CCC
5748 CCC 5813 CCC 1 .175E+00, .380E+00, .720E+00, .790E+00, .830E+00, .840E+00, 625
5749 CCC 7 .01 , .44, .0 , .0 / 5814 CCC
5750 CCC 5815 CCC 1 .370E+00, .640E+00, .920E+00, .960E+00, .980E+00, .940E+00, 630
5751 CCCC THE FOLLOWING ARE DATA FOR THE 15.0 MICRON BAND OF CO2 5816 CCC
5752 CCC 5817 CCC 1 .590E+00, .840E+00, .107E+01, .110E+01, .111E+01, .106E+01, 635
5753 CCCC TEMP, K=300 600 1200 1500 1800 2400 WAVE NO. 5818 CCC
5754 CCC 5819 CCC 1 .940E+00, .103E+01, .115E+01, .115E+01, .115E+01, .118E+01, 640
5755 CCC DATA B1/ 5820 CCC
5756 CCC 5821 CCC 1 .196E+01, .177E+01, .146E+01, .136E+01, .132E+01, .139E+01, 645
5757 CCC 1 .000E+00, .000E+00, .000E+00, .105E-01, .300E-01, .880E-01, 500 5822 CCC
5758 CCC 5823 CCC 1 .345E+01, .282E+01, .198E+01, .172E+01, .156E+01, .148E+01, 650
5759 CCC 1 .000E+00, .000E+00, .000E+00, .180E-01, .490E-01, .880E-01, 505 5824 CCC
5760 CCC 5825 CCC 1 .282E+01, .248E+01, .200E+01, .190E+01, .186E+01, .205E+01/ 655
5761 CCC 1 .000E+00, .000E+00, .000E+00, .300E-01, .540E-01, .740E-01, 510 5826 CCC
5762 CCC 5827 CCC DATA B5/
5763 CCC 1 .000E+00, .000E+00, .000E+00, .300E-01, .560E-01, .890E-01, 515 5828 CCC
5764 CCC 5829 CCC 1 .254E+01, .234E+01, .184E+01, .176E+01, .174E+01, .203E+01, 660
5765 CCC 1 .000E+00, .000E+00, .000E+00, .330E-01, .690E-01, .990E-01, 520 5830 CCC
5766 CCC 5831 CCC 1 .142E+02, .860E+01, .370E+01, .260E+01, .196E+01, .142E+01, 665
5767 CCC 1 .000E+00, .000E+00, .880E-02, .380E-01, .720E-01, .970E-01, 525 5832 CCC
5768 CCC 5833 CCC 1 .450E+01, .570E+01, .580E+01, .520E+01, .350E+01, .420E+01, 670
5769 CCC 1 .000E+00, .000E+00, .110E-01, .530E-01, .950E-01, .124E+00, 530 5834 CCC
5770 CCC 5835 CCC 1 .360E+01, .310E+01, .330E+01, .290E+01, .205E+01, .200E+01, 675
5771 CCC 1 .000E+00, .000E+00, .285E-01, .630E-01, .990E-01, .140E+00/ 535 5836 CCC
5772 CCC 5837 CCC 1 .310E+01, .260E+01, .200E+01, .196E+01, .180E+01, .210E+01, 680
5773 CCC DATA B2/ 5838 CCC
5774 CCC 5839 CCC 1 .240E+01, .250E+01, .230E+01, .220E+01, .170E+01, .194E+01, 685
5775 CCC 1 .000E+00, .000E+00, .330E-01, .680E-01, .103E+00, .134E+00, 540 5840 CCC
5776 CCC 5841 CCC 1 .182E+01, .200E+01, .218E+01, .205E+01, .184E+01, .130E+01, 690
5777 CCC 1 .000E+00, .000E+00, .450E-01, .920E-01, .138E+00, .176E+00, 545 5842 CCC
5778 CCC 5843 CCC 1 .104E+01, .135E+01, .172E+01, .172E+01, .165E+01, .130E+01/ 695
5779 CCC 1 .000E+00, .000E+00, .490E-01, .970E-01, .148E+00, .191E+00, 550 5844 CCC
5780 CCC 5845 CCC DATA B6/
5781 CCC 1 .000E+00, .000E+00, .490E-01, .120E-01, .188E+00, .247E+00, 555 5846 CCC
5782 CCC 5847 CCC 1 .550E+00, .120E+01, .143E+01, .147E+01, .148E+01, .125E+01, 700
5783 CCC 1 .000E+00, .000E+00, .480E-01, .126E+00, .201E+00, .241E+00, 560 5848 CCC
5784 CCC 5849 CCC 1 .136E+01, .128E+01, .128E+01, .135E+01, .138E+01, .134E+01, 705
5785 CCC 1 .000E+00, .000E+00, .820E-01, .198E+00, .270E+00, .265E+00, 565 5850 CCC

5851 CCC 1 .210E+00, .780E+00, .127E+01, .133E+01, .137E+01, .132E+01, 710 5916 CCC
5852 CCC 5917 CCC DATA B10/
5853 CCC 1 .190E+00, .780E+00, .140E+01, .146E+01, .147E+01, .142E+01, 715 5918 CCC
5854 CCC 5919 CCC 1 .000E+00, .000E+00, .000E+00, .330E-01, .560E-01, .750E-01, 860
5855 CCC 1 .900E+00, .106E+01, .140E+01, .150E+01, .155E+01, .134E+01, 720 5920 CCC
5856 CCC 5921 CCC 1 .000E+00, .000E+00, .000E+00, .300E-01, .530E-01, .750E-01, 865
5857 CCC 1 .720E-01, .300E+00, .800E+00, .100E+01, .115E+01, .126E+01, 725 5922 CCC
5858 CCC 5923 CCC 1 .000E+00, .000E+00, .000E+00, .290E-01, .530E-01, .850E-01, 870
5859 CCC 1 .640E-01, .210E+00, .560E+00, .720E+00, .860E+00, .102E+01, 730 5924 CCC
5860 CCC 5925 CCC 1 .000E+00, .000E+00, .000E+00, .240E-01, .470E-01, .900E-01, 875
5861 CCC 1 .680E-01, .210E+00, .530E+00, .670E+00, .790E+00, .101E+01/ 735 5926 CCC
5862 CCC 5927 CCC 1 .000E+00, .000E+00, .000E+00, .220E-01, .450E-01, .860E-01, 880
5863 CCC DATA B7/ 5928 CCC
5864 CCC 5929 CCC 1 .000E+00, .000E+00, .000E+00, .000E+00, .000E+00, .000E+00,
5865 CCC 1 .690E-01, .210E+00, .540E+00, .690E+00, .820E+00, .910E+00, 740 5930 CCC
5866 CCC 5931 CCC 1 .000E+00, .000E+00, .000E+00, .000E+00, .000E+00, .000E+00,
5867 CCC 1 .330E-01, .140E+00, .390E+00, .530E+00, .690E+00, .770E+00, 745 5932 CCC
5868 CCC 5933 CCC 1 .000E+00, .000E+00, .000E+00, .000E+00, .000E+00, .000E+00/
5869 CCC 1 .230E-01, .780E-01, .270E+00, .410E+00, .560E+00, .890E+00, 750 5934 CCC
5870 CCC 5935 CCCC THE FOLLOWING DATA ARE FOR THE 7.7 MICRON BAND OF CH4
5871 CCC 1 .300E-01, .860E-01, .280E+00, .400E+00, .520E+00, .710E+00, 755 5936 CCC
5872 CCC 5937 CCCC TEMP,K= 290 600 850 WAVE NO.
5873 CCC 1 .175E-01, .620E-01, .225E+00, .335E+00, .450E+00, .660E+00, 760 5938 CCC
5874 CCC 5939 CCC DATA C1/
5875 CCC 1 .105E-01, .450E-01, .180E+00, .280E+00, .380E+00, .600E+00, 765 5940 CCC
5876 CCC 5941 CCC 1 0., 0., 0.,
5877 CCC 1 .450E-02, .300E-01, .148E+00, .240E+00, .345E+00, .570E+00, 770 5942 CCC
5878 CCC 5943 CCC 1 0., 0., 0.03,
5879 CCC 1 .000E+00, .140E-01, .124E+00, .205E+00, .285E+00, .430E+00/ 775 5944 CCC
5880 CCC 5945 CCC 1 0., 0., 0.22,
5881 CCC DATA B8/ 5946 CCC
5882 CCC 5947 CCC 1 0.16, 0.20, 0.47,
5883 CCC 1 .000E+00, .115E-01, .110E+00, .185E+00, .260E+00, .375E+00, 780 5948 CCC
5884 CCC 5949 CCC 1 0.34, 0.34, 0.62,
5885 CCC 1 .000E+00, .135E-01, .840E-01, .140E+00, .205E+00, .335E+00, 785 5950 CCC
5886 CCC 5951 CCC 1 0.69, 0.53, 0.65,
5887 CCC 1 .000E+00, .430E-02, .650E-01, .120E+00, .185E+00, .325E+00, 790 5952 CCC
5888 CCC 5953 CCC 1 1.27, 0.88, 1.09,
5889 CCC 1 .000E+00, .000E+00, .540E-01, .115E+00, .180E+00, .315E+00, 795 5954 CCC
5890 CCC 5955 CCC 1 1.68, 1.38, 0.87/
5891 CCC 1 .000E+00, .000E+00, .440E-01, .950E-01, .150E+00, .270E+00, 800 5956 CCC
5892 CCC 5957 CCC DATA C2/
5893 CCC 1 .000E+00, .000E+00, .360E-01, .790E-01, .125E+00, .205E+00, 805 5958 CCC
5894 CCC 5959 CCC 1 0.55, 0.28, 0.40,
5895 CCC 1 .000E+00, .000E+00, .250E-01, .650E-01, .110E+00, .178E+00, 810 5960 CCC
5896 CCC 5961 CCC 1 1.25, 0.86, 0.93,
5897 CCC 1 .000E+00, .000E+00, .180E-01, .620E-01, .103E+00, .153E+00/ 815 5962 CCC
5898 CCC 5963 CCC 1 0.34, 0.59, 0.75,
5899 CCC DATA B9/ 5964 CCC
5900 CCC 5965 CCC 1 0., 0.13, 0.25,
5901 CCC 1 .000E+00, .000E+00, .320E-01, .580E-01, .860E-01, .147E+00, 820 5966 CCC
5902 CCC 5967 CCC 1 0., 0., 0.06,
5903 CCC 1 .000E+00, .000E+00, .800E-02, .510E-01, .870E-01, .134E+00, 825 5968 CCC
5904 CCC 5969 CCC 1 0., 0., 0.,
5905 CCC 1 .000E+00, .000E+00, .600E-02, .480E-01, .830E-01, .133E+00, 830 5970 CCC
5906 CCC 5971 CCC 1 0., 0., 0.,
5907 CCC 1 .000E+00, .000E+00, .000E+00, .430E-01, .780E-01, .118E+00, 835 5972 CCC
5908 CCC 5973 CCC 1 0., 0., 0./
5909 CCC 1 .000E+00, .000E+00, .000E+00, .420E-01, .700E-01, .108E+00, 840 5974 CCC
5910 CCC 5975 CCCC THE FOLLOWING DATA ARE FOR THE 3.3 MICRON BAND OF CH4
5911 CCC 1 .000E+00, .000E+00, .000E+00, .360E-01, .640E-01, .980E-01, 845 5976 CCC
5912 CCC 5977 CCCC TEMP, K= 290 600 850
5913 CCC 1 .000E+00, .000E+00, .000E+00, .350E-01, .610E-01, .870E-01, 850 5978 CCC
5914 CCC 5979 CCC DATA C3/
5915 CCC 1 .000E+00, .000E+00, .000E+00, .320E-01, .580E-01, .860E-01/ 855 5980 CCC
5981 CCC 1 0., 0., 0.03, 6046 CCC
5982 CCC 6047 CCC 1 0., 0., 0.03,
5983 CCC 1 0., 0., 0.03, 6048 CCC
5984 CCC 6049 CCC 1 0., 0., 0./
5985 CCC 1 0., 0., 0.03, 6050 CCC
5986 CCC 6051 CCC END
5987 CCC 1 0., 0., 0.06, 6052 CCC
5988 CCC 6053
5989 CCC 1 0.03, 0.03, 0.09,
5990 CCC
5991 CCC 1 0.07, 0.07, 0.12,
5992 CCC
5993 CCC 1 0.09, 0.09, 0.12,
5994 CCC
5995 CCC 1 0.14, 0.15, 0.22/
5996 CCC
5997 CCC DATA C4/
5998 CCC
5999 CCC 1 0.18, 0.22, 0.28,
6000 CCC
6001 CCC 1 0.24, 0.31, 0.37,
6002 CCC
6003 CCC 1 0.33, 0.44, 0.47,
6004 CCC
6005 CCC 1 0.45, 0.50, 0.53,
6006 CCC
6007 CCC 1 0.59, 0.62, 0.62,
6008 CCC
6009 CCC 1 0.74, 0.70, 0.68,
6010 CCC
6011 CCC 1 0.91, 0.77, 0.72,
6012 CCC
6013 CCC 1 1.00, 0.81, 0.75/
6014 CCC
6015 CCC DATA C5/
6016 CCC
6017 CCC 1 1.03, 0.84, 0.78,
6018 CCC
6019 CCC 1 1.03, 0.84, 0.78,
6020 CCC
6021 CCC 1 1.00, 0.81, 0.75,
6022 CCC
6023 CCC 1 0.94, 0.77, 0.72,
6024 CCC
6025 CCC 1 0.72, 0.68, 0.68,
6026 CCC
6027 CCC 1 0.52, 0.63, 0.63,
6028 CCC
6029 CCC 1 0.33, 0.50, 0.56,
6030 CCC
6031 CCC 1 0.25, 0.42, 0.50/
6032 CCC
6033 CCC DATA C6/
6034 CCC
6035 CCC 1 0.17, 0.26, 0.37,
6036 CCC
6037 CCC 1 0.08, 0.18, 0.31,
6038 CCC
6039 CCC 1 0.04, 0.11, 0.22,
6040 CCC
6041 CCC 1 0., 0.06, 0.16,
6042 CCC
6043 CCC 1 0., 0.02, 0.12,
6044 CCC
6045 CCC 1 0., 0., 0.06,