United States
Environmental
Protection
Agency
Office of Air Quality
Planning and Standards
Research Triangle Park, NC 27711
EPA-450/4-89-009b
JULY 1989
SEPA
AIR
USER'S MANUAL FOR OZIPM-4
(OZONE ISOPLETH PLOTTING
WITH OPTIONAL MECHANISMS)
VOLUME 2: COMPUTER CODE
-------
-------
EPA-450/4-89-009b
USER'S MANUAL FOR OZIPM-4
(OZONE ISOPLETH PLOTTING
WITH OPTIONAL MECHANISMS)
VOLUME 2: COMPUTER CODE
OFFICE OF AIR QUALITY PLANNING AND STANDARDS
U. S. ENVIRONMENTAL PROTECTION AGENCY
RESEARCH TRIANGLE PARK, NC 27711
JULY 1989
-------
This report has been reviewed by the Office Of Air Quality Planning And Standards, U. S. Environmental
Protection Agency, and has been approved for publication. Any mention of trade names or commercial
products is not intended to constitute endorsement or recommendation for use.
EPA-450/4-89-009b
11
-------
PREFACE
This document is one of five related to application of EKMA and the use
of OZIPM-4 (Ozone Isopleth Plotting with Optional Mechanisms), the computer
program used by EKMA. Listed below are the titles of the five documents and a
brief description of each.
"Procedures for Applying City-specific EKMA", EPA-450/4-89-012, July 1989
- Describes the procedures for using the Empirical Kinetic Modeling
Approach (EKMA). The major focus is on how to develop needed inputs for
OZIPM-4. In addition this document describes how to determine a control
target once OZIPM-4 has been run.
"A PC Based System for Generating EKMA Input Files", EPA-450/4-88-Q16,
November 1988
- Describes a program that creates EKMA input files using a menu driven
program. This sofware is only available for an IBM-PC or compatible
machine. Files built using this system can be uploaded to a mainframe
computer.
"User's Manual for OZIPM-4 (Ozone Isopleth Plotting with Optional Mechanisms)-
Volume 1", EPA-450/4-89-009a, July 1989
- Describes the conceptual basis behind OZIPM-4. It describes the
chemical mechanism, Carbon Bond 4, and each of the options available in
OZIPM-4. Formats for each of the options are outlined so that a user
can create input files using any text editor.
"User's Manual for OZIPM--4 (Ozone Isopleth Plotting with Optional Mechanisms)-
Volume 2: Computer Code", EPA-450/4-89-009b, July 1989
- Describes modifications to the computer code that are necessary in
order to use OZIPM-4 on various machines. A complete listing of OZIPM-4
is also found in this publication.
"Consideration of Transported Ozone and Precursors and Their Use in EKMA",
EPA-450/4-89-010, July 1989
- Recommends procedures for considering transported ozone and
precursors in the design of State Implementation Plans to meet national
ambient air quality standards for ozone. A computerized (PC) system for
determining whether an ozone exceedance is due to overwhelming transport
is described. This document is necessary, only if an area is suspected
of experiencing overwhelming transport of ozone or ozone precursors.
m
-------
EKMA may be used in several ways: (1) as a means for helping to focus more
resource-intensive photochemical grid modeling analyses on strategies most
likely to be successful in demonstrating attainment; (2) as a procedure to
assist in making comparisons between VOC and NOx controls; (3) in non-SIP
applications, such as in helping to make national policy evaluations assessing
cost/benefits associated with various alternatives and (4) for preparation of
control estimates consistent with limitations/provisions identified in Clean
Air Act Amendments.
IV
-------
TABLE OF CONTENTS
Page
Disclaimer ii
Preface iii
Introduction 1
Computer Considerations 2
OZIPM-4 Subroutines/Functions
OZIPM-4 A-l
Block Data B-l
HDWRIT C-l
MECH D-l
MCHSET E-l
MATRX F-l
MCHWRT G-l
MIXST H-l
RATES 1-1
SPARS J-l
CONVT K-l
VALU L-l
EMISS M-l
STAIR N-l
PHOT 0-1
SOLAR P-l
SPLNA Q-l
SPLNB R-l
CLOCK S-l
SUNTIM T-l
EKCALC U-l
SIM V-l
DRIVES W-l
STIFFS X-l
DIFFUN Y-l
COSET Z-l
CLKMIN AA-1
INTERP AB-1
NSBSLV ' AC-1
NSCORA AD-1
NSCORD AE-1
NSNFAC AF-1
NSSFAC AG-1
OZMX AH-1
SAVIT AM
SORDER AJ-1
YSMER AK-1
-------
TABLE OF CONTENTS (CONTINUED)
Page
CIRC AL-1
SPLOT AM-1
CURV1 AN-1
CURV2 AO-1
RLINE AP-1
LINER AQ-1
EDGMX AR-1
ISOPLT AS-1
VVMNMX AT-1
CONMAP AU-1
VVCMAP AV-1
VVKURV AW-1
WLABL AX-1
VVKRV1 -. AY-1
VVKRV2 AZ-1
AXES BA-1
FRAME BB-1
OPENA BC-1
PLOTS BD-1
-------
INTRODUCTION
The OZIPP program has been revised on several occasions. The most recent
version is OZIPM-4. Volume 1 of this document describes OZIPM-4 and how to run
the computer program. Volume 2 lists the computer code and describes modifica-
tions needed to make the software run on various machines.
OZIPM-4 contains 56 FORTRAN routines. Each subroutine has an identifying
letter as part of the line number (in the right-hand columns). The alphabetical
identifier corresponds to the page number (section) in this document.
-------
CHAPTER 1
COMPUTER CONSIDERATIONS
This chapter describes modifications that need to be made to the OZIPM-4
code in order to make it work on different computers.
Several statements in the subroutine OPENA may have to be commented out
depending on which computer system you are using. There is some inherent
incompatibility between IBM JCL and ANSI Fortran OPEN statements for which we
found the easiest solution was to comment out the OPEN statements.and several
other support lines. Also, this software was originally written so that plotting
could be accomplished using proprietary software on the IBM main-frame. Not all
computer system users have access to compatible software. Five dummy subroutines
have been written to field any calls to a plotter. Also an OPEN statement in
subroutine OPENA, which contains the coding FORM='BINARY', has been commented
out but will serve as a reminder that some plotting packages require a non ANSI
standard binary file be written for later plotting. Some compilers do not have
a binary option.
The source code for this version of EKMA has been compiled and tested on
an IBM 3090, IBM-PC/AT compatible (Microsoft compiler only), Sun 386i(UNIX
system), and a VAX 8650 computer system. The results were replicated on all four
systems using six different sets of input data. Slight differences were noted
among the output due to differences in computer processors. In one case, the
variable, NTRYS, which controls the number of cycles in which to try for a
solution to an iterative process and with a sequence identifier of U 72, was
-------
increased from 8 to 12 in order to obtain a replicated ozone concentration
instead of an approximate value.
The following are instructions for executing any one of the five data sets
on any one of the four computer systems mentioned above. The input files are
labelled with a .INP extention. The output files are labelled with a .OUT
extention while any computer processing control files (e.g. IBM JCL) are labelled
with an extention for that computer system (i.e. .IBM - for the IBM mainframe).
The data and associated function filenames are identified as EXAM1, EXAMS, EXAM4,
EXAMS and EXAM12. These filenames are associated with prior test cases that went
under the names: Testcase, EKMA, BASEISOP, FUTISOP, and PEAK, respectively. All
these files are part of the OZPC.ARC file which was downloaded from SCRAM.
(Support Center for Regulatory Air Models - Bulletin Board System).
Since the output file is set up to write to disk instead of directly to a
printer, the carriage control symbols are also printed and are not an error. The
example output files contain these symbols. You will note that column one in
these output files contain many Os and Is because of this procedure. If you want
the output to go directly to a printer, all unit references in the processing
control files (ie JCL) need to be changed from 10 to 6 and in OZPC.FOR, the 10
on line BC 76 needs to be changed to 6 (see MCB#2, step 12 for a sample of the
coding).
These instructions assume you have uploaded the files in OZPC.ARC to your
computer system.
IBM 3090(mainframe) OS/MVS system
The following instructions will allow you to process any one of the data
sets above or use the information in them to execute other data sets.
-------
1. Determine if you have a software plotting package capable of fielding
the calls to the subroutines NEWPEN, NUMBER, PLOT, PLOTS and SYMBOL.
(These calls were originally written for a Calcomp plotting package.)
a. If you do, then you will have to delete the five subroutines in
step 1. These subroutines are located after sequence identifier
BC 39 in OZPC.FOR. Go to step 2.
b. If you do not, then you go to step 2.
2. The following lines with sequence identifiers, BC 11, BC 23, BC 24,
BC 26, BC 32, and BC 35 need to be commented out. These lines are
associated with OPEN and READ statements that are used by other
computer systems.
3. . The file, OZPC.,ICL, is an example of compile and link JCL for you to
follow. Note the four lines beginning with the line that starts with
//LKED.SYSLIB...have been altered so a CALCOMP 5845 can be used.
//uid JOB (acct,bin),uid,PRTY=2,TIME=(min,sec),NOTIFY=uid
/*ROUTE PRINT HOLD
//*
//CL EXEC FORTVCL,PARM=(NOMAP,NOXREF)
//*
//FORT.SYSIN DD DSN=source.code.file.name,DISP=SHR
//*
//LKED.SYSLIB DD DSN=SYS1.VSF2FORT,DISP=SHR
//* DD DSN=SYS2.IMSL.R9M2.SP,DISP=SHR
// DD DSN=SYS2.IMSL.V1ROMO.LOAD,DISP=SHR
// DD DSN=SYS2.CALCOMP.PLOT1051,DISP=SHR
-------
//PLOTSTEP EXEC PLINIT,ACCOUNT=acct,NAME=plotname,DEST=dest
//PLOTINST DD *
DELIVER TO: user name
bin
//*
//OZPC EXEC PGM=OZPC,PARM='NOXUFLOW
//STEPLIB DD DSN=loadlib,DISP=SHR
//*
//* PARAMETER INPUT
//FT07F001 DD DSN=input.fi1ename,DISP=SHR
//* OUTPUT DIRECTLY TO PRINTER
//*FT10F001 DD SYSOUT=*
//* OUTPUT DIRECTLY TO FILE
//FT10F001 DD DSN=output.filename,
// UNIT=SYSDA,SPACE=(TRK,(45,5),RLSE),
// DCB=(RECFM=FBA,LRECL=133,BLKSIZE=2660),
// DISP=(MOD,CATLG,KEEP)
//* ALREADY FILE (READ)
//FT08F001 DD DUMMY
//* ALREADY FILE (WRITE)
//FT09F001 DD DUMMY
//* EKMA FILE
//FT11F001 DD DUMMY
//* PLOT FILE FOR CALCOMP 5845 PLOTTER
-------
//
//
//*
DD DSN=SYS2.CALCOMP.MODULES,DISP=SHR
DD DSN=SYS1.VSF2LINK,DISP=SHR
//LKED.SYSLMOD DD DSN=loadl ib,DISP=NEW
NOTE: Right-hand names are user-specified as follows:
4.
uid
acct
bin
dest
plotname
plotter.file =
user ID
account number or information
bin number
destination of printout or plot (RMTO)
OZIPM-4 plotter output name
output plotter tape file name of the form:
dest.uidacct.plotname (required only when PLOT
option is selected)
loadlib = file name of load module library
DUMMY = when data is present for this unit, a file name and
other file specifications are needed. (ie
DSN=file.name,DISP=SHR)
OZPC = member name of a partitioned data set. EKMA can
be used in its place.
The following JCL is a generic example that, when edited, will allow the user
to process data.
//uid JOB (acct,bin),name,PRTY=2,TIME=(min,sec),NOTIFY=uid
/*ROUTE PRINT HOLD
//*
-------
//GO.FT 14F001 DD DSN= plot.input.data.file.name,
// DISP=(NEW,CATLG),UNIT=DISK,SPACE=(TRK,(10,10)),
// DCB=(LRECL=80,BLKSIZE=3200,RECFM=FB,DSORG=PS)
//EXEC C58ROUTE,
// PFILE='plot.input.data.file.name;
// DEST=dest
//HEADER.DELIVER DD*
USER NAME,FILE.NAME
ADDRESS
//
IBM-PC and compatibles DOS system
OZPC.FOR is over 600 kbytes long. Most PCs, using the Microsoft Fortran
Version 5.0, can not compile the whole program at once. The program needs to be
divided into individual subroutines that are compiled one by one. The object
files for these subroutines are then linked into an executable file. The
following steps assume that you have divided OZPC.FOR into individual
subroutines.
1. If you have a plotting package that can function using the calls to
NEWPEN, NUMBER, PLOT, PLOTS, and SYMBOL, you will need to delete these
subroutines.
2. Compile and link the individual subroutines. OZPC.PCL was included for
your convenience. This file will automatically compile each subroutine
and then link the subroutines into a executable program not requiring
a link to a software plotting package. This file may have to be edited
-------
depending upon your compile and link situation. The file is executed
at the by typing: OZPC.PCL
3. Rename the executable file in step 2 to OZPC.EXE.
(ie Rename AXES.EXE OZPC.EXE)
4. A control file is necessary in order to execute OZPC.EXE. A generic
file is provided that you can edit to run the examples provided. The
file is named OZPC.PC.
5. A program can be executed by typing:
OZPC filename.ext
6. Examine your example output files and compare them with the output
examples provided from SCRAM.
VAX VMS system
The following instructions will allow you to process anyone of the data sets
above or use the information in them to execute other data sets.
1. If you have a plotting package that can function using the calls to
NEWPEN, NUMBER, PLOT, PLOTS, and SYMBOL, you will need to delete these
subroutines.
2. OZPC.FOR can be compiled and linked using the following two statements
or by executing the COM file, OZPC.VCL:
•
$FORTRAN/CROSS-REFERENCE/LIST/NOOPTIMIZE/DEBUG/SHOW/WARNINGS=NONE -
OZPC
SLINK/DEBUG OZPC
3. OZPC.VAX is an example of a control file for running your program.
Type: 00ZPC.VAX to run an example
8
-------
4. Examine your example output files and compare them with the examples
provided.
Sun 386i Unix System
This set of instructions assumes you have the files in a directory readily
accessible by the Unix system and that your Fortran listing has been converted
to a Unix readible format.
1. If you have a plotting package that can function using the calls to
NEWPEN, NUMBER, PLOT, PLOTS, and SYMBOL, you will need to delete these
subroutines.
2. Compile and link OZPC.FOR using the following statements:
f77 -ANSI ozpc.for
cp a.out to ozpc.exe
3. Copy your input files to Fort.(unit#). Unit 14 is NOT used.
cp examl.inp fort.7
4. To execute, type: ozpc.exe
5. .Rename output files from fort.(unit#) to more identifable name(s).
cp fort.10 output.filename
6. Examine your output and compare it with the examples provided.
-------
c
C**i
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c* * *
PROGRAM EKMA
********************************************************************
OZIPM-4 (EKMA)
THE OZONE ISOPLETH PLOTTING PACKAGE WITH OPTIONAL CHEMICAL
MECHANISM (VERSION 4.00) IS USED IN THE EMPIRICAL KINETICS
MODELING APPROACH (EKMA) TO ESTIMATE VOC CONTROL REQUIREMENTS
THIS VERSION WAS WRITTEN TO ANSI FORTRAN 77 STANDARDS AND
CONTAINS THE CARBON-BOND CHEMICAL MECHANISM (CBM-4) DESCRIBED
BY GERY ET AL. (1988) (EPA-600/3-88-012) .
OZIPM-4 IS AN CONDENSED VERSION OF OZIPM-3. SUPERFICIALLY,
THERE ARE NO CHANGES. THE DEFAULT MECHANISM IS THE CARBON-BOND
(VERSION 4) INSTEAD OF THE CBM-X IN OZIPM-3. THE USER IS REFERRED
TO HOGO AND GERY (1988) FOR A DESCRIPTION OF MODEL USAGE.
OZIPM-4 IS BASED ON THE ORIGINAL OZIPP PROGRAM BY WHITTEN
AND HOGO (1973) AND THE OZIPM-2 PROGRAM (GIPSON, 1984).
THIS VERSION USES THE GEAR INTEGRATION ROUTINES WRITTEN BY
SPELLMANN AND HINDMARSH (1975) .
PARTS OF THIS PROGRAM ARE CONTRIBUTIONS FROM JEFFRIES (1982) AND
GIPSON (1984). THEORETICAL PHOTOLYSIS ROUTINE ARE FROM SCHERE AND
DEMERJIAN (1977) . THE SPLINE ROUTINES ARE FROM CLINE (1974) .
CODE WRITTEN BY:
H. HOGO
M. W. GERY
R. G. JOHNSON
G. W. LUNDBERG
SYSTEMS APPLICATIONS, INC
101 LUCAS VALLEY RD
SAN RAFAEL, CA 94903
(415) 472-4011
*************** CODE REVISION DATE: MAY, 1989
BY: H. HOGO/SAI
******** DEFAULT CHEMICAL MECHANISM: CARBON-BOND VERSION 4
(AUGUST, 1987)
BY: M. GERY/SAI
********************************************************************
SAVE
COMMON /ALOFT/ IALFT, CALFT ( 10 ) , LOCALF ( 10)
COMMON /BIOG/ NBEM,IBSP, WTMOL ( 5) , ACB4 ( 5) , SURFBI ( 5) ,
1 ALOFBI (5).,REDBI (5) ,FSRFBI (5) ,FALFBI (5) ,BEMO(26,5) ,
2 BECO(126,5),CBTOT(5) ,IBLS(5) , BESTOP, BFRAC (20 , 5 )
COMMON /BK1/ FBK(20),FBKAL(5) , HCBK, XNBK, OZBK, H20BK
COMMON /CALC/ NR, KR (200, 12 ) , A (200) , S (200 ) , R (200) , ITYPE (200 ) , IA ( 60)
A
A
*A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
'A
A
A
A
A
A
A
A
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
57
58
59
60
61
62
63
A-l
-------
COMMON /CRED/
L
COMMON /EMIS/
COMMON /NEED/
COMMON /NEEDI/
L
COMMON /OPTS/
1 ,JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT,TSTEP,ZENI A
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTOfTSRT,DTIM,Zl,Z2,DCON,EHC,EXN
FLST,TLST
ICR,ISPCRf SPCR69(3),SURFCR(3),ALOFCR{3),
REDCR(3),FSRFCR(3),FALFCR(3),COSFBK,COAFBK
NEM,ISP,ESTRT(5),ESTOP,ESLP,IEMLS(5),EOSLP(5),
1 EMO(26,5),ECI(5),EM(26),EC{125),ECO(125,5)
COMMON /FRPLOT7 SAVCON(80,5),SAVTIM(SO),NTSV,INOW
COMMON /HEAT/ SC (200,12),ISC (200,3)
COMMON /HOUR/ OZM(5>,NGO,TTM,TM(5)
COMMON /INOUT/ IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
COMMON /MIX/ NMIXfAMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6),
1 AMXX(26),DL,TTMAX,SSRISE,SRMIN,DELH,TOIL,NMXX,
2 HEIGHT,SSET,SRISE
HC,XN,NL,OZP(20),OZN(11,11,5),MR,LS,HCS,XNS
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,1103,
IIH20,JPLUS
ISPD,ICAL,IACR,IDIL,IPLC,IEMS,IRDY,IBLK,IBCK,IPLT,A
1 ITRN,ITIT,IRCT,IRAT,ITIM,IMCH,INIT,ISTR,IMIX,ISPC,A
2 ITMP,IALF,IDEP,IZNI,IMAS,IMOL,ICRE,IBIO,IWAT
COMMON /PHOTON/ CF(72,20),P(24,20),IPH(20),IP,RFCT(20),PP (10,20), A
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF (125,10),
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /PLTVEC/ HCT(20),OT(20),NT,OHC,HCG,PLTGRD,OXN,XNG,HC1,XN1,
1 TICZ,DIGZ,CHRZ,IPLDEV
COMMON /SCRAT3/ WY(20)
COMMON /SCRATC/ ISPN
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
COMMON /STORE/ AST(60)
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM,ID,
1 ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),
2 XZ(24),KKK(24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,
3 MAXJ
COMMON /TEMPER/ TEMEND,NTEMP,QM(30)
COMMON /TITL/ ITTL{36)
COMMON /WLB1/ FCTR, DIST, CHRSIZ , NNCHR, OZBL
COMMON /WATER/ WATEND,NWATER,PAMB,QW(30),QR(30),PMILLI,ILH20
COMMON /ZENITH/ IPZ,ZDEF (10,20),IPHZ(20),IZENP
COMMON /ALFCHR/ ISPAL(IO)
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CALCHR/ SPEC IS (61)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*! AST
CHARACTER*2 ITTL, JTTL, ITEST
CHARACTER*4 ISPAL, ISPDP, ISPNCR, IBEMSP
CHARACTER*4 IPLACE, IOPT
CHARACTER*4 SPECIS, HCSPEC, PLSP, IISOP, ISPN, EMSP, REACT
CHARACTER*4 ISPD,ICAL,IACR,IDIL,IPLC,IEMS,IRDY,IBLK,IBCK,
IPLT,ITRN,ITIT,IRCT,IRAT,ITIM,IMCH,INIT,ISTR,IMIX,ISPC,ITMP,
IALF,IDEP,IZNI,IMAS,IMOL,ICRE,IBIO,IWAT,
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,1103,
IIH20,IBZA,JPLUS
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
,A
,A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
89A
90
91
92
93
94
95
96
97
97A
97B
97C
97D
97D
97E
97F
97G
97H
971
97J
97K
97L
97M
97N
970
97P
97Q
97R
97S
97T
97U
97X
97Y
97Z
98A
98B
98C
A-2
-------
DIMENSION X (7), IPLACE(6), JTTL(36)
DIMENSION ITTK20)
DIMENSION NRTC(200), XRTC(200),OZAR(4)
INTEGER PSPEC
INITIALIZE SOME LOCAL VARIABLES
DATA HCCON/595./,XNXCON/1890./ITEST/'ZO'/
DATA IPLACE/' LOS',' ANG','ELES',', CA','LIF.',' '/
DATA IEM,KALCMP, JS,KS1/4*0/,NC/11/
DATA JTTL /' ',' I','SO','PL','ET','H ',30*' '/
CALL DATA INITIALISATION ROUTINES
CALL OPENA
WRITE (IOUT,830)
WRITE (IOUT,831)
WRITE (IOUT,832)
CALL MECH
CALL PHOT
CALL MIXST
CALL SUNTIM
READ INPUT FILE AND PRINT IT
**** NOTE THE FOLLOWING CODE IS NOT NEEDED IN ORDER TO USE
OZIPM-4.XX. IF THE USER FINDS THAT THE INPUT FILE (DEFAULT
UNIT 7) CANNOT BE REWOUND USING REWIND STATEMENT THEN
EITHER THE INPUT UNIT NUMBER NEEDS TO BE CHANGED OR
THE FOLLOWING SECTION OF CODE CAN BE COMMENTED OUT.
WRITE (IOUT,980)
DO 30 1=1,1000
READ (IN,850) ITT1
DO 10 IJ=1,20
IF (ITTl(IJ).NE.IBLK) GO TO 20
10 CONTINUE
GO TO 40
20 IF(MOD(1,50).EQ.O) WRITE (IOUT,980)
WRITE (IOUT,, 860) ITT1
30 CONTINUE
40 CONTINUE
REWIND IN
OPTIONS LOOP
DO 820 IOPTLP=1,1000
READ(IN,840) IOPT,(X(I),1=1,6)
DO ISOPLETH
IF (IOPT.NE.ISPD) GO TO 60
IF (ABS(X(D).NE.O.) HC=X(1)
IF (ABS(X(2)).NE.O.) XN=X(2)
IF
-------
CALL RLINE (KS1,JS)
DO 50 K=1,NOZ
49 IF (NUMPSP.GT.l.AND.K.GT.l) READ (IN,880) (OZP(I),1=1,NL)
ISPN=PLSP(K)
CALL LINER (KALCMP,OZN(1,1,K))
50 CONTINUE
INFO=0
JS=0
GO TO 820
DO INDIVIDUAL, CALCULATIONS
60 IF (IOPT.NE.ICAL) GO TO 80
NPTO=1
INFO=1
, NE. 0
, NE. 0
TPRNT=X(4)
TSTEP=X(5)
IF (ABS(X(3» .NE.O
TPRNT=60.
TSTEP=60.
IF (ABS(X(4))
IF (ABS(X{5))
NTSV=0
CALL HDWRITdPLACE, IEM)
CALL SIM (X{1),X(2),ZN,1)
IF (INFO.EQ.l)
DO 70 1=1,NOZ
IF (TM(I).GT.O.) TMX=CLOCK(FLOAT(JSTRT),IFIX(TM(I)))
IF (TM(I) .GT.O.) WRITE (IOUT,900) PLSP (I) , OZM (I) , TM.X
IF (TM(I).LE.O.) WRITE (IOUT,940) PLSP(I),OZM(I)
WRITE (IOUT,870)
c
c
c
c
c
c
70 CONTINUE
CALL SPLOT
NPTO=0
INFO=0
GO TO 820
IMPLEMENT ACCURACY OPTION
80 IF (IOPT.NE.IACR) GO TO 90
IF (ABS(X(1) ) .NE.O.) NC=IFIX(X{1)+0
IF ( (NC/2) .EQ. ( (NC + D/2) ) NC=NC+1
IF (ABS(X(2) ) .NE.O.) MR=IFIX (X (2 ) +0
IF (ABS(X{3)> .NE.O.) ERR=X(3)
IF (ABS(X(4) ) .NE.O.) SIG=X(4)
IF (ABS(X(5) ) .NE.O.) SIGMA=X(5)
IF (ABS(X(6) ) .NE.O.) NGO=0
GO TO 820
READ PLACE OPTION
90 IF (IOPT.NE.IPLC) GO TO 100
IF (ABS(X{1) ) .NE.O.) SLA=X(1)
IF (ABS(X(2) ) .NE.O.) SLO=X(2)
IF (ABS(X(3) ) .NE.O.) TZ=X(3)
IF (ABS(X(4)) .NE.O.) IY=IFIX (X (4 ) +0
IF (ABS(X(5)) .NE.O.) IM=IFIX (X (5) +0
IF (ABS(X(6) ) .NE.O.) ID=IFIX (X (6) +0
.1)
.1)
.01)
.01)
.01)
IF(ABS(X(1)).NE.O
1)
CALL PHOT
CALL MIXST
CALL SUNTIM
GO TO 820
READ MORNING AND AFTERNOON MIXING HEIGHTS
,OR.ABS(X(2)).NE.O.)READ(IN,930)(IPLACE(I),1=1,
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
6A
A
A
A
A
A
A
A
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
A-4
-------
A 219
100 IF (IOPT.NE.IDIL) GO TO 110 A 220
IF (ABS(X(D).NE.O.) Z1=X(1) A 221
IF (ABS(X(2)).NE.O.) Z2=X(2) A 222
IF (ABS(X(3».NE.O.) DSTRT=X(3) A 223
IF (ABS(X(4)>.NE.O.) DEND=X(4) A 2?4
AMIX(l)=-3. , 225
CALL MIXST A „ 6
CALL SUNTIM A 227
JMIN=IFIX(DSTRT)-((IFIX(DSTRT)/100)*100) A 228
TMIN1=FLOAT{(IFIX(DSTRT)/100)*60+JMIN) A 22g
JMIN=IFIX(DEND)-((IFIX(DEND)/100)*100) A 230
TMIN2=FLOAT((IFIX(DEND)/100)*60+JMIN) A 231
JMIN=JSTRT-{(JSTRT/100)*100) A 232
TMIN3=FLOAT{(JSTRT/100)*60+JMIN) A 233
TMIN4=AMAX1(TMIN1,TMIN3,SSRISE) A 234
TSRT=TMIN4--TMIN3 A 235
IF (TSRT.GT.O.) DTIM=TMIN2-TMIN4 A 236
IF (TSRT.LE.O.) DTIM=TMIN2-TMIN3 A 237
IF (DTIM.LT.O.) DTIM=0. a
DCON=ABS(X{5)) *
c G° T° 82° A 240
C READ HOURLY MIXING HEIGHTS \ 242
A 94 ~\
110 IF (IOPT.NE.IMIX) GO TO 150 a
NMIX=IFIX(X(1)+0.1>+1 ?
DO 120 I»l,5 A
120 AMIX(I)=X(I+1) . ^ 247
IF (NMIX-5.GT.O) READ(IN,880) (AMIX(I),1=6,NMIX) A 248
A
STRM=0. "
STOPM=FLOAT(NMIX-1)*60. A
NMX4=(NMIX-1)*3 J
DO 130 I = 1,NMX4 a
130 DC(I)=0. J
NMIX1=NMIX-1
DO 140 I=1,NMIX1 a 9^c
K=3*I-2 A 256
DC(K)=(AMIX(I+1)-AMIX(I))/60. A
140 CONTINUE *
DTIM=STOPM ^
TSRT=0. ^
GO TO 820 ^
C A
C READ HOURLY TEMPERATURE DATA a
A 9 c c
150 IF (IOPT.NE.ITMP) GO TO 161 a
NTEMP=IFIX{X(1)+0.1)+1
DO 160 1=1,5 *
160 QM(I)=X(I+1) J
IF (NTEMP-5.GT.O) READ(IN,880) (QM (I ) , 1=6, NTEMP) A
QM(NTEMP + 1):=2.*QM(NTEMP)-QM(NTEMP-1) . A
QM(NTEMP+2)=3.*QM
-------
PAMB=1.0
IF (ABS(X{2)).NE.O.) PMILLI=X(2)
IF (ABS(X{2)).NE.O.) PAMB=PMILLI/29.9213
READ (IN,880) (QR(I),1=1,NWATER)
WATEND=FLOAT(NWATER-1)*60.
TFACT=l./273.
TNOW=TEMP
DO 165 I=l,rNWATER
RH1=QR(I)
IF (NTEMP.GT.O.AND.I.LE.NTEMP) TNOW=QM(I)
IF (NTEMP.GT.O.AND.I.GT.NTEMP) TNOW=QM(NTEMP)
IF (TNOW.GE.273.) RCONST=18.02*{597.3-.566*{TNOW-273.))/1.9869
IF (TNOW.LT.273.) RCONST=6133.17
IF (QR(I) .GT.100.). RH1 = 100.
IF (QR(I).LT.O.) RH1=0.
QW(I)={6030.*.01*RH1/PAMB)*EXP(RCONST*(TFACT-1./TNOW))
165 CONTINUE
QW(NWATER+1)=2.*QW(NWATER)-QW(NWATER-1)
QW(NWATER+2)=3.*QW(NWATER)-2.*QW(NWATER-1)
GO TO 820
READ EMISSIONS
170 IF (IOPT.NE.IEMS) GO TO 220
NEM=IFIX(X(1)+0.1)
IEM=IFIX(ABS(X(1))+0.1)
ESTOP=FLOAT(IEM)* 60.
IF (X(l).LT.(-0.99999999)) GO TO 190
DO 180 1=1,5
180 EM(I)=ABS(X(I+1))
IF (NEM-5.GT.O) READ(IN,880) (EM(I),1=6,NEM)
CALL EMISS (NEM,EM,EC)
ISP=2
EMSP(1) = IIHC
EMSP(2)=IINX
GO TO 820
190 DO 200 1=1,5
200 EMO(I,1)=X(I+1)
IF (EMO{1,1).LT.(-0.0001)) GO TO 210
ISP=1
EMSP(1)=IIHC
IF (IEM-5.GT.O) READ(IN,880) (EMO(I,I),1=6,IEM)
CALL EMISS (IEM,EMO(1,1),ECO(1,1))
210 READ(IN,880) (EMO(I,2),1=1,7)
IF (EMO{1,2) .LT. (-0.0001)) GO TO 820
ISP=2
EMSP(2)=IINX
IF (IEM-7.GT.O) READ(IN,880) (EMO(I,2),1=8,IEM)
CALL EMISS (IBM,EMO(1,2),ECO(1,2))
GO TO 820
READ EMISSIONS (MOLAR UNITS)
220 IF (IOPT.NE.IMOL) 30 TO 300
NEM=IFIX(X(1)+0.1)
IEM=IFIX(ABS(X(1) ) 4-0.1)
ESTOP=FLOAT(IEM)*63.
IF (X(l) .LT. (-0.99999999)) GO TO 240
DO 230 1=1,5
230 EM(I)=ABS(X(I+1))
IF (NEM-5.GT.O) READ(IN,880) (EM(I),1=6,NEM)
CALL EMISS (NEM,EM,EC)
GO TO 820
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
275F
275G
275H
2751
275J
275K
275L
27 6M
275N
2750
275P
275Q
275R
275S
275T
275U
275V
275W
275X
275Y
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302.
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
A-6
-------
240 ISP-IFIX(ABS(X{2))+0.1)
FHT=X(3)
DAREA=X(4)
HCEM=X(5)
XNEM=X(6)
EFACT=1.
IF (FHT.GT.O.) EFACT=24450./FHT
IF (FHT.GT.O..AND.DAREA.GT.O.) EFACT=24450./(FHT*DAREA)
IF (ISP.GT.2) READ (IN,880) (SPRSE(I),1=3,ISP)
SPRSE(1)=HCEM
SPRSE(2)=XNEM
DO 290 1=1,ISP
READ (IN,840) EMSP(I),(EMO(J,I),J=l,6)
IF (IEM-6.GT.O) READ (IN,880) (EMO{J,I),J=7,IEM)
IF (EMSP(I).NE.IIHC.AND.EMSP(I).NE.IINX) GO TO 260
CONCEN=HCEM
IF (EMSP(I).EQ.IINX) CONCEN=XNEM
QO=EFACT/CONCEN
DO 250 J=1,IEM
EMO(J,I)=EMO(J,I)*QO
250 CONTINUE
GO TO 280
CONVERT OTHER SPECIES
260 CONTINUE
QO=EFACT/SPRSE(I)
DO 270 J=1,IEM
EMO(J,I)=EMO(J,I)*QO
270 CONTINUE
280 CALL EMISS (IEM,EMO(1,I),ECO(1, I) )
290 CONTINUE
GO TO 820
READ EMISSIONS (MASS UNITS)
THIS OPTION WAS IMPLEMENTED IN OZIPM-2
300 IF (IOPT.NE.. IMAS) GO TO 330
NEM=IFIX(X(1)+0.1)
IEM=IFIX(ABS(X(1) )+0.1)
ESTOP=FLOAT(IEM)*60.
ISP=2
EMSP(1)=IIHC
EMSP(2)=IINX
READ (IN,880) (EMO(I,1),1=1,JEM)
READ (IN,880) (EMO(I,2),1=1,IEM)
HCEM=X(2)
XNEM=X(3)
FHT=X{4)*.OC1
DO 320 1=1,ISP
CONCEN=HCEM
IF (EMSP(I).EQ.IINX) CONCEN=XNEM
CONV=HCCON
IF (EMSP(I).EQ.IINX) CONV=XNXCON
Q0=l./(CONV*CONCEN*FHT)
DO 310 J=l,IEM
EMO(J,I)=EMO(J,I)*QQ
310 CONTINUE
CALL EMISS (IEM,EMO(1,I),ECO(1,I))
320 CONTINUE
ISP=2
GO TO 820
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
A-7
-------
c
c
C A 382
C READ CALCOMP PLOTTING OPTION A 383
C A 384
330 IF (IOPT.NE.IPLT) GO TO 340 A 385
KALCMP=1 A 386
FCTR=0.6 A 387
HC1=8.5 A 388
XN1=5.95 A 389
CHRZ=0.10 A 390
IF (ABS(XCL)) .NE.O.) FCTR=X(1) A 391
PLTGRD=X(2) A 392
IF (ABS(X(3)).NE.O.) HC1=X{3) A 393
IF (ABS(X(4)).NE.O.) XN1=X(4) A 394
IF (ABS(X(5)).NE.O.) CHRZ=X(5) A 395
IF (ABS(X(6)).NE.O.) CHRSIZ=X(6) A 396
DIGZ=CHRZ A 397
TICZ=CHRSIZ A 398
GO TO 820 A 399
c A 400
C PERFORM VOC CONTROL REQUIREMENT ESTIMATIONS BASED ON A 401
C CITY-SPECIFIC EKMA GUIDELINES A 402
C A 403
340 IF (IOPT.NE.ISTR) GO TO 350 A 404
C A 405
C ALL EKMA CALCULATIONS ARE DONE IN SUBROUTINE EKCALC A 406
A 407
CALL HDWRITdPLACE, IEM) A 408
A 409
C CALL EKMA SUBROUTINE TO CALCULATE VOC CONTROL REQUIREMENTS A 410
C A 411
CALL EKCALC (X) A 412
GO TO 820 A 413
A 414
C READ REACTIVITIES A 415
A 416
350 IF (IOPT.NE.IRCT) GO TO 360 A 417
KHC=IFIX(X(1)+0.1) A 418
IF (ABS(X(2)).NE.O.) XNF(1)=X(2) A 419
IF (ABS(X(2)).NE.O.) XNF(2)=1.-X(2) • A 420
IF (KHC.GT.O) READ(IN,880) (RCTY(I),1=1,KHC) A 421
GO TO 820 A 422
A 423
C READ SPECIES OF INTEREST A 424
A 425
360 IF (IOPT.NE.ISPC) 30 TO 410 A 426
IF (ABS(X(1)).GT.O.) NOZ=IFIX(X(1)+0.1) A 427
READ(IN,950) (PLSP (I),1 = 1,NOZ) A 428
DO 380 J=1,NOZ A 429
DO 370 1=1,NS A 430
IF (SPECIS(I).NE.PLSP(J)) GO TO 370 A 431
KOZ(J)=I A 432
GO TO 380 A 433
370 CONTINUE A 434
WRITE (IOUT,970) PLSP(J) A 435
STOP A 436
380 CONTINUE A 437
390 IF (PLSP(l).EQ.II03 ) GO TO 820 A 438
IF (ITTL(6).NE.ITEST ) GO TO 820 A 439
DO 400 1=1,36 A 440
400 ITTL(I)=JTTL(I) A 441
GO TO 820 A 442
A 443
C READ TITLE A 444
A-8
c
c
c
c
c
-------
A 445
410 IF (IOPT.NE.ITIT) GO TO 420 A 446
READ(INf850) (ITTL (I) , 1=1, 36) A 447
GO TO 820 A
A
C READ TRANSPORT OPTIONS A
C A 451
420 IF (IOPT.NE.ITRN) GO TO 440 a
OZIN=X<1) £
OZAL=X(2) ?
HCIN=X(3) J
HCAL=X(4) £
XNIN=X{5) £
XNAL=X(6) £
IF (HCIN.GT. (-0.0000001)) GO TO 430 a
JIN=IFIX(ABS(HCIN)-h0.1) A
READ(IN,880) HCIN, (FINHC (I) , 1=1, JIN) A 461
430 IF (HCAL.GT. (-0.0000001)) GO TO 820 A
JAL=IFIX(ABS(HCAL)H-0.1) A
READ(IN,880) HCAL, (FALHC (I ) , 1=1, JAL) A
GO TO 820 *
- A 465
C READ BACKGROUND CONDITIONS A
A
440 IF (IOPT.NE.IBCK) GO TO 450 C
OZBK=X(1) £
HCBK=X(2) J
XNBK=X(3) J
IF (HCBK.GE. (-0.00001)) GO TO 820 A 47o
JBK=IFIX(ABS(X(2))-f-0.01) A
READ (IN, 880) HCBK, (FBK ( I) , 1=1 , JBK) A
GO TO 820 J
C A
C READ ALOFT CONCENTRATIONS OF SPECIES OTHER THAN 03,NMOC,NOX A 478
A 4 7 Q
450 IF (IOPT.NE.IALF) GO TO 480 a
IALFT=IFIX(ABS(X(1))+0.01) a
READ (IN, 950) (ISPAL (I ) , 1 = 1, IALFT) a
DO 470 I=lf IALFT £
DO 460 J=1,NS £
IF (ISPAL(I) .NE.SPECIS(J)) GO TO 460 ' A
LOCALF(I)=J J
GO TO 470 ?
460 CONTINUE ^
470 CONTINUE
READ (IN, 880) (CALFT (I ) , 1=1, IALFT) a 4qn
GO TO 820 , ™
C A 491
C READ INITIAL CONDITIONS FOR ALL SPECIES OTHER THAN 03,NMOC,NOX A 493
480 IF (IOPT.NE.INIT) GO TO 490 a
a
= IFIX(ABS(X(1))+0.1) ?
READ(IN,950) (REACT ( I) , 1 = 1 , NI ) 7
READ(IN,880) (C ( I) , [ = 1, NI) ?
GO TO 820
c A 499
C READ SURFACE DEPOSITION RATE (CM/SEC) A
\-t
490 IF (IOPT.NE.IDEP) GO TO 530 J
IDPTIM=IFIX(ABS(X(1))+0.01) ?
IDEPO=IFIX(ABS(X(2))+0.01) J
DPEND=FLOAT(IDPTIM) *60. C
DO 520 I = 1,IDEPO *
A- 9
-------
READ (IN,840) ISPDP(I), (RDEP1(J,I),J=l,6) A 508
IF (IDPTIM-6.GT.O) READ (IN,880) (RDEP1(J,I),J=7,IDPTIM) A 509
DO 500 J=l,IDPTIM A 510
RDEPO(J,I)=RDEP1(J,I)*36. A 511
500 CONTINUE A 512
CALL EMISS(IDPTIM,RDEPO(1,1),RDCOEF(1,1)) A 513
IF (ISPDP(I).EQ.IIHC) GO TO 520 A 514
DO 510 J=1,NS A 515
IF (ISPDP(I).NE.SPECIS(J)) GO TO 510 A 516
LOCDEP(I)==J A 517
GO TO 520 A 518
510 CONTINUE A 519
520 CONTINUE A 520
GO TO 820 A 521
C A 522
C READ ALREADY COMPLETED SIMULATIONS A 523
C A 524
530 IF (IOPT.NE.IRDY) GO TO 560 A 525
KS1=IFIX(ABS(X(1))+0.1) A 526
JS=2 A 527
IF (NOZ.EQ.l) WRITE (IOUT,910) PLSP(l) A 528
IF (NOZ.GT.l) WRITE (IOUT,910) (PLSP(I),1=1,NOZ) A 529
DO 550 1 = 1,KS1 A 530
IF (X(l).GT.O.) READXIN,880) HCC, XNN, ZN, OZAR A 531
IF (X(l) .LT. (-0-.98)) READ (IALL,990) HCC, XNN, ZN, OZAR A 532
WRITE (IALN,990) HCC,XNN,ZN,OZAR A 533
IF (XNN.GT.O.) RT01=HCC/XNN A 534
IF (XNN.LE.O.) RT01=HCC*1.0E7 A 535
NOZM1=NOZ-1 A 536
IF (NOZ.EQ.l) WRITE (IOUT,920) HCC,XNN,RT01,ZN A 537
IF (NOZ.GT.l) WRITE (IOUT,920) HCC,XNN,RT01,ZN,(OZAR(JJ),JJ=1,NO A 538
1ZM1) A 539
JJ=MOD(I,11) A 54Q
IF (JJ.EQ.O) JJ=11 A 541
II=(I-JJ)/11 + 1 A 542
.OZN(JJ,II,1)=ZN A 543
IF (NOZ.LE.l) GO TO 550 A 544
DO 540 JK=2,NOZ A 545
OZN(JJ,II,JK)=OZAR(JK-1) A 546
540 CONTINUE A 547
550 CONTINUE A 54g
GO TO 820 A 549
C A 550
C READ CHEMICAL MECHANISM A 551
A 552
560 IF (IOPT.NE.IMCH) GO TO 650 A 553
IZENP=1 A 554
IF (X(l).LE.O.) CALL MCHWRT A 555
IF (ABS(X(5)).NE.O.) TEMP=X(5) A 556
IF (QM(1).GT.O.) TEMP=QM(1) A 557
IF (X(l).LT.O.) GO TO 820 A 558
NX=IFIX(ABS(X(1))+0.1) A 559
IP=IFIX(ABS(X(2))+0.1) A 56Q
NHC=IFIX(ABS(X(3)1+0.1) A 561
NEPA=IFIX(ABS(X(4))+0.1) A 562
IF (IP.NE.O) READ(IN,880) (XRTC(I),1=1,IP) A 563
IF (IP.EQ.O) GO TO 600 a
DO 570 1=1,IP \
570 IPH(I)=IFIX(XRTC(I)+0.1) A
A 567
C PLACE ZENITH ANGLE.DEPENDENCE INTO APPROPRIATE SLOT FOR EACH REACTIONA 568
DO 590 K=1,IP I 5576Q9
A-10
-------
DO 580 1-1,10
PP(I,K)=1. A 571
580 CONTINUE A 572
590 CONTINUE A ?Z3
IF (NHC.NE.O) READ(IN,950) (HCSPEC(I),1=1,NH
IF (NHC.NE.O) READ(IN,880) (CARB(I),1=1,NHC)
600 IF (NHC.NE.O) READ(IN,950) (HCSPEC(I),1=1,NHC) A S7R
IF (NHC.NE.O) READ(IN,880) (CARB(I),1=1,NHC) J 576
CALL MCHSET (NX,NEPA) A 576
ILH20=-1 " A 577
DO 640 J=1,NS A 577A
DO 610 1=1,NHC A 578
IF (SPECIS(J).NE.HCSPEC(I)) GO TO 610 A cl?
IH(I)=J A 58°
GO TO 640 A 581
610 CONTINUE A ^82
620 IF (SPECIS(J).EQ.IIN02 ) INOX(1)=J A
IF (SPECIS(J).EQ.IINO ) INOX(2)=J A
DO 630 K=1,NOZ
630 IF (SPECIS(J).EQ.PLSP(K)) KOZ(K)=J a
IF (SPECIS(J).EQ.IIH20 ) ILH20=J *
640 CONTINUE A
INHH=1 A 588
CALL PHOT A 589
CALL MIXST A 589A
CALL SUNTIM A 589B
GO TO 820 A 589C
C A 590
C MODIFY RATE CONSTANTS USING THE RATE OPTION £ 593
650 IF (IOPT.NE.IRAT) GO TO 720 A 593
NRR=IFIX(X(l)+.l) A 594
IF (ABS(X(2)).NE.O.) GO TO 700 A
READ(IN,880) (XRTC(I),1=1,NRR) A ,Q.
DO 660 1=1,NRR A 597
660 NRTC(I)=IFIX(XRTC(T)+.l) 598
READ(IN,880) (XRTC (I) , 1=1, NRR) A HI
DO 690 1=1,NRR A 60°
J=NRTC(I) A 601
DO 670 JK=1,IP A 602
IF (J.EQ.IPH(JK)) RFCT(JK)=XRTC(I) A ^°3
IF (J.EQ.IPH(JK)) GO TO 680 , °4
670 CONTINUE A 605
680 CONTINUE A 606
690 A(J)=XRTC(I) A 607
GO TO 820 A 608
700 DO 710 1=1,NR A 609
710 A(I)=0. A 61°
GO TO 820 A 611
C A 612
C READ DESIRED SIMULATION TIME A 613
C A 614
720 IF (IOPT.NE.ITIM) GO TO 730 A 615
START=0. A 616
STOPP=600. A 617
JSTRT=800 A 618
JSTOP=1900 A 619
IF (ABS(X(2)).EQ.O.) GO TO 820 A ?2°
JSTRT=IFIX(X(1)+0.1) A 621
JSTOP=IFIX(X(2)+0.1)+100 A 622
JMIN=JSTRT-((JSTRT/100)*100) A 623
TMIN1=FLOAT((JSTRT/100)*60+JMIN) A f24
JMIN=.JSTOP-( (JSTOP/100) *100)
TMIN2=FLOAT((JSTOP/LOO)*60+JMIN) A 626
STOPP=TMIN2-TMIN1 A 627
A 628
A-ll
-------
STOPP=STOPP-60.
******* UPDATED 11/81 FOR 24 HR TIME
IF (STOPP.LE.O.) STOPP-1440.+STOPP
CALL PHOT
CALL MIXST
CALL SUNTIM
GO TO 820
ZENITH ANGLE OPTION
730 IF (IOPT.NE.IZNI) GO TO 780
IPZ=IFIX(X(1)+0.1)
DO 770 K=1,IPZ
READ (IN,880) (XRTC(I),1=1,11)
IPNW=IFIX(XRTC(1)+0.01)
DO 740 J=1,IP
IF (IPNW.EQ.IPH(J)) GO TO 750
740 CONTINUE
WRITE (IOUT,960) 1PNW
STOP
750 DO 760 1=1,10
PP (I, J)=XRTC(I'+1)
IF (J.EQ.l) RTCON(I)=RTCON(I)*XRTC(I+1)
IF (J.EQ.l) PP(I,J)=1.
760 CONTINUE
770 CONTINUE
GO TO 820
INPUT EMISSION REDUCTION CREDITS (CURRENTLY IMPLEMENTED FOR CO
780 IF (IOPT.NE.ICRE) GO TO 801
ICR=1
IF (X(l).GT.O.) ICR=IFIX(XU)+0.1)
IF (X(l).LT.-0.0001) ICR=0
IF (X{1).LT.-0.0001) GO TO 820
IEMCR=IFIX (ABS(X(2))+0.1)
NEMCR=IFIX (X(2)+0.1)
DO 800 J=l,ICR
READ (IN,840) ISPNCR(J),SPCR69{J),SURFCR(J),ALOFCR(J),REDCR
1FSRFCR(J),FALFCR(J)
JX=J+2
EMSP(JX)=ISPNCR(J)
READ (IN,880) (EMO(I,JX),1=1,7)
IF ((IEMCR-7).GT.C) READ (IN,880) (EMO(I,JX),1=8,IEMCR)
IF (NEMCR.GT.O) CALLEMISS (IEMCR,EMO(1,JX),ECO(1,JX))
IF (NEMCR.GT.O) GO TO 800
FHT=X(3)*.001
QO=1./(1145.*SPCR69(J)*FHT)
DO 790 1=1,IEMCR
EMO (I, JX) =EMO (I, JX) *QO
790 CONTINUE
CALL EMISS (IEMCR,EMO(1,JX),ECO(1,JX))
800 CONTINUE
GO TO 820
INPUT BIOGENIC EMISSIONS
801 IF (IOPT.NE.IBIO) GO TO 810
NBEM=IFIX(ABS(X(1))+0.1)
BESTOP=FLOAT(NBEM)*60.
IBSP = IFIX(ABS(X(2) )+0 . 1)
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
ONLY) A
A
A
A
A
A
A
A
A
A
(J), A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
684A
684B
684C
684D
684E
684F
684G
A-12
-------
FHT=X(3)*.001
EFACT1=.024450/FHT
DO 805 J=lfIBSP
CBTOT(J)=0.
IFSR^BI ( J)' ^LFBH J? P ( J
READ (IN, 8 80) WTMOL(J)
IF (ACB4(J) .LE.O.) GO TO 803
READ (IN, 880) (BFRAC ( I, J) , 1=1, NHC)
DO 802 1=1,, NHC
CBTOT ( J) =CBTOT ( J) +BFRAC ( I, J) *CARB (I)
802 CONTINUE
803 READ (IN, 880) (BEMO (I, J) , I=1,NBEM)
EFACT=EFACT1/WTMOL ( J)
DO 804 I=1,,NBEM
BEMO ( I , J) =BEMO ( I , J) *EFACT
804 CONTINUE
CALL EMISS (NBEM,BEMO(1, J),BECO(1, J) )
805 CONTINUE
GO TO 820
' REDBI < J)
WRITE (IOUT,890) IOPT
810 IF (IOPT.NE.IBLK)
STOP
820 CONTINUE
STOP
830 FORMAT ('!' /////////)
831 FORMAT (IX //////////)
832 FORMAT (49X,39H***************************
249X,39H*
OZONE ISOPLETH PLOTTING PACKAGE
WITH OPTIONAL MECHANISMS
*********
OZIPM-4 (EKMA)
EKMA(90005)
******
)
349X,39H*
449X,39H*
549X,39H*
649X,39H*
749X,39H*
849X,39H*
149X,39H*
249X,39H*****
840 FORMAT (A4 , 6X, 7F10 .2)
850 FORMAT (36A2)
860 FORMAT (10X,f36A2)
870 FORMAT (1H1//)
880 FORMAT (7F10.5)
<1H1,24HTHE OPTIONS INSTRUCTION ,A4,21H CANNOT BE PROCESSED
'°9HfLD?MAXIT ^ ^ *™ 'A4'1X'3H = ^7-5,12H CE
'" 14Xr36HTHE FOLLOWING RESULTS WERE READ IN. ////1H
930 FORMAT (6A4)
NOT REACHED, THE LAST ONE
950 FORMAT (7{A4,6X))'
960 FORMAT (1HO, 9HREACTION ,I10,10H NOT FOUND)
970 FORMAT (1H1, 39X,8HSPECIES ,A4,38H IS NOT FOUND IN THE KINETIC MECHA
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
A
)A
A
PA
A
A
A
A
A
IA
A
A
A
[A
A
684H
6841
684J
684K
684L
684M
684N
6840
684P
684Q
684R
684S
684T
684U
684V
684W
684X
684Y
684Z
685
685A
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
A-13
-------
980 FORMAT (1H1//////1HO,28HTHE INPUTS FOR THIS RUN ARE //) A 728
990 FORMAT (1X,7E13.4) A 729
END • A 730-
A-14
-------
BLOCK DATA
SAVE
COMMON /CALC/
NR,KR(200f12),A(200),S(200),R(200),ITYPE(200),
IA(60),JA(800),DILUT,TEMP,ERR,START.STOPP,TPRNT
2 TSTEP,ZENI '
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTO,TSRT, DTIM, Zl,Z2,DCON,EHC,EXN
COMMON /HEAT/
COMMON /SPEC/
COMMON /OPTS/
FLST,TLST
SC(200,12),ISC(200,3)
NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
ISPD, ICAL, IACR, IDIL, IPLC, IEMS, IRDY, IBLK, IBCK, IPLT, B
'IMCH' IN"> ISTR, IMIX, ISPC, B
COMMON /EMIS/
L
COMMON /MIX/
ITMP,IALF,IDEP,IZNI,IMAS,IMOL,ICRE,IBIO,IWAT
NEM,ISP,ESTRT(5),ESTOP,ESLP,IEMLS(5),EOSLP(5)
EMO(26,5),ECI(5),EM(26),EC(125),ECO<125,5)
NMIX,AMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6)
1 AMXX(26),DL,TTMAX,SRISE,SRMIN,DELH,TOIL,NMXX,
2 HEIGHT,SSET,SSRISE
COMMON /TEMPER/ TEMEND,NTEMP,QM(30)
COMMON /INOUT/ IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
ITTL(36)
HC,XN,NL,OZP(20),OZN(11,11,5),MR,LS,HCS,XNS
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103,
IIH20,JPLUS
OZM(5),NGO,TTM,TM(5)
COMMON /PLTVEC/ HCT(20),OT(20),NT,OHC,HCG,PLTGRD,OXN,XNG,HC1,XN1
TICZ,DIGZ,CHRZ,IPLDEV
COMMON /WLB1/ FCTR, DIST, CHRSIZ, NNCHR, OZBL
COMMON /BK1/ FBK(20),FBKAL(5),HCBK,XNBK,OZBK,H20BK
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM ID
2 5?T?Tf I?.T9P' ™CL IEND' SPECIE, MAXZ, ITIME (24) , '
COMMON
COMMON /TITL/
COMMON /NEED/
COMMON /NEEDI/
L
COMMON /HOUR/
^r!24)'K(24)'JSTRT'JSTOP'pSPEC,MNLM,MXLM,MAXL,MAXJB
IPZ,ZDEF (10,20),IPHZ(20),IZENP R
COMMON /PHOTON/ CF (72,20),P(24,20),IPH(20),IP,RFCT (20),PP(10,20) B
COMMON /ALOFT/
COMMON /GEARI/
COMMON /PLTND/
IDE:PO,RDEPO(26,10),LOCDEP(10),RDCOEF{125,10)
IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
IALFT,CALFT(10),LOCALF(10)
TTDUM(5),UROUND,NNDUM(4)
JBAR,JSYMB,CVERT{9),TVERT(52,2)
COMMON /EXPVAL/ EXPMAX
COMMON /CRED/ ICF:, ISPCR, SPCR69 (3) , SURFCR (3) , ALOFCR (3)
REDCR(3),FSRFCR(3),FALFCR(3),COSFBK,COAFBK
NBEM,IBSP,WTMOL(5),ACB4(5),SURFBI(5),ALOFBI(5)
RECBI(5),FSRFBI(5),FALFBI(5),BEMO(26,5),
BECO(126,5),CBTOT(5),IBLS(5),BESTOP,BFRAC(20,5)
WATEND,NWATER,PAMB,QW(30)fQR(30),PMILLI,ILH20
COMMON /BIOG/
COMMON /WATER/
INTEGER PSPEC
COMMON /ALFCHR/ ISPAL(IO)
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CALCHR/ SPECIS(61)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*! JBAR, JSYMB
CHARACTER*2 ITTL
CHARACTERS ISPAL, ISPDP, ISPNCR, IBEMSP
B
B
B
B
B
, B
B
B
B
, B
B
T,B
C,B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
. B
B
B
B
B
B
[JB
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
18A
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
43A
43B
43C
43D
43E
44
44A
44B
44C
44D
44E
44F
44G
44H
441
44J
44K
44L
44M
B-l
-------
CHARACTER*4 TVERT, CVERT
CHARACTER*'? SPEC IS, HCSPEC, PLSP, 11 SOP, EMSP, REACT
CHARACTER*-? ISPD, ICAL, IACR, IDIL, IPLC, IEMS, IRDY, IBLK, IBCK, IPLT,
ITRN,ITIT,IRCT,IRAT,ITIM,IMCH,INIT,ISTR,IMIX,ISPC,
I IMP, IALF, IDEP, IZNI,IMAS, IMOL, ICRE, IBIO, I WAT,
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,I103,
IIH20,IBZA,JPLUS
PLOTTING DATA
DATA JBAR/'I'/,JSYMB/'0'/
DATA TVERT/17*' ',' C
1' T ',' R ',' A ',' T
2' P ',' M ',70*' '/
UROUND (ROUND-OFF ERROR), EXPMAX IS THE MAXIMUM EXPONENT ALLOWED
DATA UROUND/1.25E-7/,EXPMAX/87.
DATA TEMEND/0./,WATEND/0./
DATA ISPD/'ISOP'/,ICAL/'CALC'/,
1 IPLC/'PLAC'/,IEMS/'EMIS'/,
2 IPLT/'PLOT'/,ITRN/'TRAN'/,
3 IRAT/'RATE'/,ITIM/'TIME'/,
4 IMIX/'MIXI'/,ISPC/'SPEC'/,
5 II03/'03 '/,IIHC/'VOC '/,
6 ITMP/'TEMP'/,IALF/'ALOF'/,
7 IMAS/'MASS'/,ICRE/'CRED'/,
8 UNO/'NO '/,IIH20/'H20 '/
9 JPLUS/" + '/,IBIO/'BIOG'/
SET DEFAULTS
4/
IACR/'ACCU'/,
IRDY/'ALRE'/,
ITIT/'TITL'/,
IMCH/'MECH'/,
ISTR/'EKMA'/,
IINX/'NOX '/,
IDEP/'DEPO'/,
IICO/'CO '/,
,MBLANK/'M
,IWAT/'WATE'/
IDIL/'DILU'/,
IBLK/' '/,
IRCT/'REAC'/,
INIT/'INIT'/,
IMOL/'MOLE'/,
IBCK/'BACK'/,
IZNI/'ZENI'/,
IIN02/'N02 '/,
'/,IBLANK/'
,IISOP/'ISOP'/
DATA HC/2.0/,XN/0.14/,NL/ll/,MR/5/
DATA ITTL/'ST','AN','DA','RD',' 0','ZO','NE',' I','SO','PL'
1 'H ','CO','ND','IT','IO','NS',19*' ' /
FILE I/O UNITS
DATA IN/7/,IOUT/10/,IALN/9/,IALL/8/,IOZC/11/
DATA INFO/0/,NPTO/0/,NGO/1/
DATA OZP/.08, .12, .16, .20, .24, .28, .30, .32, .34, .36, .40,9*0. /
DATA TSRT/0.0/,DTIM/420./,Z1/510./,Z2/630./,DCON/0.0/
DATA SIG/2./,SIGMA/2./
DATA NMIX/0/,AMIX(l)/-3./,NEM/0/
DATA DSTRT/800./,DEND/1500./,PLTGRD/0./,OHC/0./,FCTR/0.6/
DATA TICZ/0.07/,DIGZ/0.10/,CHRZ/0.10/,HCl/8.5/,XNl/5.95/
DATA CHRSIZ/0.07/,QM(l)/-3./,IPLDEV/-l/
DATA NOZ/1/,PLSP/'03 ',4*' '/,
1KOZ/4,4*0/
DATA ICR/0/,ISPCR/0/,IBSP/0/
DEFAULT REACTIVITIES
DATA RCTY/.037,.035, .052, .021, .089,.117, .564,.085,12*0./,
1 FINHC/.034, .020, . 037, .070, . 042, .026, .498, .273,12*0 . /,
2 FALHC/.034, .020, .037, .070, .042, .026, .498, .273,12*0./,
3XNF/.25,.75/,
4FENX/.05,.95/,NI/0/,CARB/2.,2.,2.,l.,7.,8.,l.,l.,12*0./
DATA HCSPEC/'ETH ','OLE ','ALD2','FORM','TOL ','XYL ' 'PAR
1'NR ',12*' ' /
DATA IH/25,24,17,16,26,32,21,34f12*0/,INOX/l,2/,NHC/8/
SET UP DEFAULT TRANSPORTED CONCENTRATIONS
IPLT,
ISPC,
N ',
P ',
)WED
'/,
', 'ET' ,
/
r
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
B
44N
440
44P
44Q
44R
44S
44T
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
B-2
-------
c DATA OZIN/0./,OZM,/0./,HCIN/0./,HCAL/0./,XNIN/0./,XNAL/0./ B 102
C SET UP BACKGROUND CONCENTRATIONS
-------
DATA IALFT/0/,IDEFO/0/,DPEND/0./,IDPTIM/0/,DNOWS/0./ B 163
C B 164
C DATA FOR CBM4.3 MECHANISM B 165
C B 166
DATA SPECIS/'N02 ','NO ','0 ','03 ','NO3 ','OID ','H20 ', B 167
1 'OH ','H02 ','N205','HN03','HN02'f'PNA ','H202', B 168
2 'CO ','FORM','ALD2'f'C203','X02 'f'PAN ','PAR ', B 169
3 'X02N','ROR ','OLE ','ETH ','TOL ','CRES','T02 ', B 170
4 'OPEN','CRO ','MGLY','XYL ','ISOP','NR ','M ', B 171
5 26*' ' / B 172
DATA KR/1,3,4,3*3,1,4,4,6,6,4,4,4*5,2*10,2,2,2,12,8,12,1,8,9, B 173
1 9,13,8,9,9,14,8,8,5*16,4*17,2*18,20,2*18,8,21,3*23,3,8,4,5,3 B 174
2 ,8,4,26,2*28,8,27,30,3*29,8,8,31,3,8,4,5,19,22,19,34,120*0,2, B 175
3 1,1,2,4,3*0,7,8,9,0,2,1,1,7,0,2,1,8,0,2*12,8,11,2,1,0,13,9,9, B 176
4 0,14,15,8,0,0,3,5,3,8,5,0,2,1,0,18,9,0,8,0,0,1,4*24,3*25,8,2,0 B 177
5 ,27,5,1,0,8,4,32,31,0,4*33,2,2,19,139*0,7,11*0,7,167*0,2,4,1,2, B 178
6 5,1,5,3,6,3,8,9,8,1,1,2,10,11,5,1,2*12,2,1,2,11,5,8,13,9,1, B 179
7 2*14,8,9,3*9,15,8,11,3*18,2*16,20,18,3*16,2*19,9,0,17,16,17, B 180
8 19,16,19,16,9,1,27,2*30,0,18,19,17,9,19,18,9,19,16,22,1,0,0, B 181
9 34,118*0,3,12*0,3,0,1,0,0,1,3*0,8,0,1,0,0,1,0,1,6*0,2*15,0,9 B 182
1 ,9,8,0,11,9,1,0,1,3*19,22,17,0,0,9,17,2*16,9,16,15,19,9,9,19, B 183
2 11,0,9,15,18,19,18,9,17,16,17,136*0,2,25*0,2*15,3*0,15,9,0,0, B 184
3 5*9,0,0,19,21,19,22,15,17,9,27,29,0,9,0,0,15,9,16,27,0,15,24, B 185
4 9, 25,167*0, 2*19, 3*0, 8, 0,17, 21, 0,0, 15,19, 8, 17,19, 9, 0,28,0,-0,29, B 186
5 3*0,18,19,31,0,C,19,22,31,174*0,21,22,0,0,16,9,15,1,8,9*0,16, B 187
6 15,21,0,0,15,25,21,174*0,2*23,0,0,22,0,9,21,11*0,8,28,0,0,25, B 188
7 31,15,178*0,21,0,21,12*0,9,3*0,21,18,9,178*0,8,14*0,31,4*0,17, B 189
8 8,323*0/ B 190
DATA A/1.0,4.3230E+06,26.64,13750.,2309.,2438.,.04731,.053,1.0, B 191
1 424600.,3.26,100.,3. ,33. 9,44160., .5901,1853.,!.9E-06,2.776, B 192
2 1.5390E-04,1.6E-11,9799.,.1975,9770.,!.5E-05,16820.,217.9, B 193
3 12270.,2025.,5.115,6833.,4144., .2181, .189,2520.,322.,15000., B 194
4 1.0,1.0,237.,.93,636.,24000.,3.7,1.0,18315.,12230.,.0222,3700., B 195
5 9600.,21.,1203.,137100.,95445.,22000.,5920.,42000.,.018,11.35, B 196
6 1080.,11920.,2.7020E-03,9150.,12000.,250.,61000.,32500.,20000., B 197
7 8.40,44000.,.015,36200.,26000.,8.96,27000.,142000.,.018,470., B 198
8 12000.,1000.,2000.,1.0,118*0.07 B 199
DATA S/0.0,-1175.,1370.,0.0,-687.,-602.,2450.,0.0,0.0,-390., B 200
1 0.0,940.,580.,0.0,-250.,1230.,-256.,0.0,10897.,-530.,0.0, B 201
2 -806.,3*0.0,-713.,-1000.,-240.,-749.,10121.,-380.,-1150., B 202
3 -5800.,0.0,187.,4*0.0,1550.,0.0,986.,-250.,2*0.0,-250.,-5500., B 203
4 14000.,2*0.0,1710.,0.0,8000.,2*0.0,324.,-504.,2105.,0.0,792., B 204
5 -411.,2633.,-322.,7*0.0,500.,-116.,8*0.,-1300.,119*0.O/ B 205
DATA SC/610*1.,2.,2*1., .89,2.,2*1.,2.,1.,2*2.,12*1.,2.,3*1., B 206
1 2.,10*1.,2.,.79,1.,.87,.96,2*1.,.63,1.,.5,.91,3*1.,.44,.9,1., B 207
2 -4,4*1., ..03, .7,2*1., .6,138*1., .89,30*1.,2.,3*1.,2., .79,1., .13, B 208
3 1.1,1.,-2.1, .38,1., .74,1.,1.7,1.56,.42,.08, .9,1.,.6,1.,.3,1.,2 . B 209
4 ,.62,.5,2*1.,.8,1.,.4,2*1.,.2,133*1.,.11,34*1.,2.,.79,1.,.11, B 210
5 .94, .04, ,,02, .28,-!., .22, . 09, 1. , . 22, . 12, . 36, . 9, . 56, . 6, . 3, 2*1. , B 211
6 2.,.7, .2,2*1., .55, .67, .55, .1, .1, .06, .1,168*1., .79 ,1., .11, B 212
7 -2.1,2*1.,, .3,1., .1,1., .7,2*1., .56, 2*1.,. 3, 4*1.,. 03,. 8, 2*1., B 213
8 .5,.13,.2,174*1.,-.11,.04,2*1.,.2,1.,.33,1.,.3,10*1.,.69,1.1, B 214
9 2*1.,.5,!.,.!,174*1.,.76,.02,2*1., .02,1.,.44,-!.,11*1., .08, .3, B 215
1 2*1.,.45,.4,.06,178*1.,.22,1.,-1.,12*1.,.76,3*1.,.9,.2,.44, B 216
2 178*1.,.2,14*1., .2,4*1., .2, .1,323*1./ B 217
END B 218-
B-4
-------
SUBROUTINE HDWRIT(IPLACE,IEM)
SAVE
THIS SUBROUTINE WRITES THE HEADER PAGE FOR THE CURRENT CALCULATIONS
COMMON /CALC/
COMMON /CNTRL/
I
COMMON /SPEC/
NRfKR(200,12),A(200),S(200),R(200),ITYPE{200),
IA(60),JA(800),DILUT,TEMP,ERR, START,STOPP,TPRNT
TSTEP,ZENI
SIGrSIGMA,INFO,NPTO,TSRT,DTIM,21,Z2,DCON,EHC,EXN,
FLST,TLST
NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM ID
1 ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),'
2 XZ<24),KKK(24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,
J MAXJ
COMMON /PHOTON/ CF(72,20),P{24,20),IPH(20),IP,RFCT(20),PP(10,20),
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10),
^ „_ , IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /ZENITH/ IPZ,ZDEF (10,20),IPHZ(20),IZENP
COMMON /EMIS/ NEM,ISP,ESTRT(5),ESTOP,ESLP,IEMLS(5),EOSLP(5)
* ^ t EMO(26,5),ECI(5),EM(26),EC(125),ECO(125,5)
COMMON /MIX/ NMIX,AMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6)
1 AMXX(26),DL,TTMAX,SSRISE,SRMIN,DELH,TDIL,NMXX,
2 HEIGHT,SSET,SRISE
COMMON /TEMPER/ TEMEND,NTEMP,QM(30)
COMMON /FRPLOT/ SAVCON(80,5),SAVTIM(SO),NTSV,INOW
COMMON /INOUT/ IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
ITTL{36)
HC,XN,NL,OZP(20),OZN(11,11,5),MR,LS,HCS,XNS
SC(200,12),ISC(200,3)
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103,
IIH20,JPLUS
AST(60)
OZM(5) ,NGO,TTM,TM(5)
COMMON /TITL/
COMMON /NEED/
COMMON /HEAT/
COMMON /NEEDI/
L
COMMON /STORE/
COMMON /HOUR/
COMMON /PLTVEC/ HCT(20),OT(20),NT, OHC,HCG,PLTGRD,OXN,XNG,HC1,XN1,
COMMON /ALOFT/
COMMON /WLB1/
COMMON /BK1/
COMMON /CRED/
L
COMMON /BIOG/
COMMON /WATER/
TICZ,DIGZ,CHRZ,IPLDEV
IALFT,CALFT(10) , LOCALF(10)
FCTR,DIST,CHRSIZ,NNCHR,OZBL
FBK(20),FBKAL(5),HCBK,XNBK,OZBK,H20BK
ICR,ISPCR,SPCR69(3),SURFCR(3),ALOFCR(3),
REDCR(3),FSRFCR(3),FALFCR(3),COSFBK,COAFBK
NBEM,IBSP,WTMOL(5),ACB4(5),SURFBI(5),ALOFBI(5),
REDBI(5),FSRFBI(5),FALFBI(5),BEMO(26,5) ,
BECO(126,5),CBTOT(5),IBLS(5),BESTOP,BFRAC(20,5)
WATEND,NWATER,PAMB,QW(30),QR(30),PMILLI,ILH20
COMMON /ALFCHR/ ISPAL(IO)
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CALCHR/ SPECIS(61)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*! AST
CHARACTER*2 ITTL
CHARACTERS ISPAL, ISPDP, ISPNCR, IBEMSP
CHARACTER*4 IPLACE
CHARACTER*4 SPECIS, HCSPEC, PLSP, IISOP, EMSP, REACT
c
c
c
c
c
c
c
c
c
r C
c
c
, c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
1
2
3
4
5
6
7
8
8A
9
10
11
12
13
14
15
ISA
16
17
18
19
20
21
22
23
24
24A
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
42A
42B
42C
42D
42E
42F
42G
42H
421
42J
42K
42L
42M
42N
420
42P
42Q
42R
42S
C-l
-------
CHARACTER*4 IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,I103,
1 IIH20,IBZA,JPLUS
DIMENSION ITMIX{26), IZC(IO), XRTC(IOO), IPLACE(6)
INTEGER PSPEC
DATA IZC/0,10,20,30,40,50,60,70,78,86/, IFRST/1/
IF (IZENP.LE.O.OR.IFRST.NE.1) GO TO 30
IFRST=2
WRITE (IOUT,140) IZC
DO 20 K=1,IP
J=IPH(K)
I=KR(J,1)
DO 10 LL=1,10
IF (K.EQ.l) XRTC(LL)=RTCON(LL)*RFCT(K)*PP(LL, K)
IF (K.NE.l) XRTC(LL)=PP(LL,K)*RFCT{K)*RTCON{LL)*RFCT(1)
10 CONTINUE
WRITE (IOUT,150) J,SPECIS(I),(XRTC(LL),LL=1,10)
20 CONTINUE
30 CONTINUE
WRITE (IOUT,160) (ITTL(I),1=1,36)
KSTOP=JSTOP-100
WRITE (IOUT,170) IPLACE,SLA,SLO,TZ,IM,ID,IY,JSTRT,KSTOP
NOON=SPECIE
IRISE=SRISE
ISET=SSET
IF (INFO.EQ.(-1)) WRITE (IOUT,180) NOON,IRISE,ISET
IF (NMIX.GT.O) GO TO 50
DDTRT=FLOAT(JSTRT)+(TSRT/60.)*100.
DDEND=DDTRT+(DTIM/60.)*100.
WRITE (IOUT,190) Zl,Z2,DDTRT,DDEND
ITMIX(1)=DDTRT
NMX=INT(DTIM/60.+0.5)+1
DO 40 J=2,NMX
40 ITMIX(J)=ITMIX(J-1)+100
WRITE (IOUT,410) (ITMIX(J),J=l,NMX)
WRITE (IOUT,420) (AMXX(J),J=l,NMX)
IF (DCON.GT.O.) WRITE (IOUT,200) DCON
GO TO 60
50 NMIX1=NMIX-1
WRITE (IOUT,360)
WRITE (IOUT,370)
60 IF (QM(1).LT.O.) GO TO 65
NTEMP1=NTEMP-1
WRITE (IOUT,450) (I,1=1,NTEMP1)
WRITE (IOUT,460)
65 IF (QW(1).LT.O.) GO TO 70
NWAT1=NWATER-1
WRITE (IOUT,470) (I,1=1,NWAT1)
WRITE (IOUT,480)
WRITE (IOUT,490)
WRITE (IOUT,500)
(AMIX(I),I=1,NMIX)
,I=1,NTEMP)
(QR(I),I=1,NWATER)
(I,I=1,NWAT1)
(QW(I),I=1,NWATER)
WRITE (IOUT,510) PMILLI
IF (ILH20.LE.O) WRITE (IOUT,520)
70 WRITE (IOUT,270)
IF (NHC.NE.O) WRITE (IOUT,210) (HCSPEC(I),RCTY(I),1=1,NHC)
IF (HCIN.GT.O.) WRITE (IOUT,390) (HCSPEC(I),FINHC(I),1=1,NHC)
IF (HCAL.GT.O.) WRITE (IOUT,400) (HCSPEC(I),FALHC(I),1=1,NHC)
IF (HCBK.GT.O.) WRITE (IOUT,430) (HCSPEC(I),FBK(I),1=1,NHC)
WRITE (IOUT,280) XNF(l)
IF (NHC.EQ.O) WRITE (IOUT,260)
IF ( (OZIN+HCIN+XNIN) .GT. 0.0 .OR.
1 WRITE (IOUT,380)
(OZAL+HCAL+XNAL) .GT. 0.0)
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
42T
42U
42V
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
86A
86B
86C
86D
86E
86F
86G
86H
87
88
89
90
91
92
93
94
95
C-2
-------
IF (OZIN+HCIN+XNIN.GT.O.) WRITE (IOUT,220) OZIN,HCIN,XNIN
,MT ™ n "^.(OZIN+HCIN+XNIN.LE.O..AND.OZAL+HCAL+XNAL.LE.O.)
IF (NI.NE.O) WRITE (IOUT,290) (REACT(I),C(I),1=1,NI)
IF (OZAL+HCAL+XNAL.GT.O.) WRITE (IOUT,230) OZAL,HCAL,XNAL
IF (IALFT.GT.O) WRITE (IOUT,300) (ISPAL(I),CALFT(I),1=1,IALFT)
IF (OZBK+HCBK+XNBK.GT.O.) WRITE (IOUT,440) OZBK,HCBK,XNBK
IF (NEM.GT.O) WRITE (IOUT,240) (I,I=1,NEM)
IF (NEM.GT.O) WRITE (IOUT,250) (EM(I),1=1,NEM)
IF (NEM.GT.(-1).AND.ICR.LE.O) GO TO 110
ISP1=ISP+ICR
IB1=1
IF (NEM.GT.-l) IB1=3
DO 90 J=1,NS
DO 80 I=IB1,ISP1
IF (EMSP(I).EQ.IIHC .OR.EMSP(I).EQ.IINX ) GO TO 80
IF (SPECIS(J).NE.EMSP(I)) GO TO 80
IEMLS(I)=J
GO TO 90
80 CONTINUE
90 CONTINUE
WRITE (IOUT,310) (J,J=1,IEM)
DO 100 I=IB1,ISP1
100 WRITE (IOUT,330) EMSP(I),(EMO(J,I),J=l,IEM)
110 CONTINUE
IF (IBSP.LE.O) GO TO 119
WRITE (IOUT,307)
WRITE (IOUT,308) (IBEMSP(I),SURFBI(I),1=1, IBSP)
WRITE (IOUT,309) (IBEMSP(I),ALOFBI(I),1=1,IBSP)
DO 111 J=1,IBSP
XX=XX+ACB4(J)
111 CONTINUE
IF (XX.LE.O.) GO TO 115
WRITE (IOUT,391)
DO 112 J=1,IBSP
IF (ACB4(J).LE.O
WRITE (IOUT',392)
112 CONTINUE
115 CONTINUE
DO 117 1=1,IBSP
DO 116 J=1,NS
IF (SPECIS(J).NE.IBEMSP(I)) GO TO 116
IBLS(I)=J
GO TO 117
116 CONTINUE
117 CONTINUE
) GO TO 112
IBEMSP(J),(HCSPEC(I),BFRAC(I,J),I=1,NHC)
119
130
WRITE (IOUT,311)
DO 118 1=1,IBSP
(J,J=1,NBEM)
IF (IDPTIM.LE.O) GO TO 130
WRITE (IOUT,320) ( J, J=l, IDPTIM)
DO 120 1=1, IDEPO
RETURN
FORMAT STATEMENTS
7// 42X,48HTHE FOLLOWING PHOTOLYSIS RATE CONSTANTS
C
.)) C
C
C
C
) C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
AREC
/ C
C
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
120A
120B
120C
120D
120E
120F
120G
120H
1201
12 OJ
120K
120L
120M
120N
1200
120P
120Q
120R
120S
120T
120U
120V
120W
120X
120Y
120Z
121
122
123
124
125
126
127
128
129
130
131
132
133
C-3
-------
150 FORMAT (1HO,11X,13,8X,A4,IX,IP,10E10.2)
160 FORMAT (1H1 // 40X,36A2)
170 FORMAT (1HO // 40X,40HPHOTOLYTIC RATE CONSTANTS CALCULATED FOR ///C
149X,6A4 /// 40X,9HLATITUDE ,F10.3 // 40X, 9HLONGITUDE ,F10.3 //
20X,9HTIME ZONE,F7.1 // 40X,5HDATE ,5X,3(I4,3X) // 40X,5HTIME ,7X,IC
34,3X,2HTO,3X,I4,5X,19HLOCAL DAYLIGHT TIME)
180 FORMAT (1HO,39X,10HSOLAR NOON,17 / 1HO,39X,10HSUNRISE ,17,
17X,10HSUNSET ,17)
190 FORMAT (1HO // 40X,39HDILUTION DETERMINED FROM THE FOLLOWING ,, ,w
10X,17HINVERSION HEIGHTS,5X,7HINITIAL,F7.0,5X,5HFINAL,4X,F7.0 // 40C
2X,7HTIMING ,15X,5HSTART,F9.0,5X,4HSTOP,4X,F8.0)
200 FORMAT (1HO,39X,55HDILUTION RATE BEFORE AND AFTER THE INVERSION CHC
1ANGE WAS // 37X,1PE12.3,9H PER MIN.)
210 FORMAT ((1HO,39X,10HEMISSIONS ,6X,3(A4,9H FRACTION,F6.3,3X)))
220 FORMAT (/ 40X,13HSURFACE LAYER,8X,5HOZONE,F9.3,6X,11HHYDROCARBON,FC
17.3,4X,3HNOX,F10.3,4H PPM)
230 FORMAT (/ 40X,5HALOFT,16X,5HOZONE,F9.3,6X,11HHYDROCARBON,F7.3,4X,3C
1HNOX,F10.3,4H PPM)
240 FORMAT (1HO // 40X,50HCONTINUOUS EMISSIONS (EXPRESSED AS THE FRACTC
1ION OF // 40X,54HINITIAL NON-BACKGROUND CONCENTRATION EMITTED PER C
2HOUR) // 40X,4HHOUR,3X,1016 / 47X,7I6)
250 FORMAT (1HO,39X,8HFRACTION,10F6.3 / 48X,7F6.3)
260 FORMAT (1HO,39X,42HTHERE ARE NO HYDROCARBONS IN THE MECHANISM)
270 FORMAT (// 40X,10HREACTIVITY)
280 FORMAT (1HO,39X,7HN02/NOX,6X,F6.3)
290 FORMAT ((1HO,39X,13HSURFACE LAYER,8X,A4,1X,F9.3,6X,A4,5X,F9.3
1,4X,A4,F9.3,4H PPM))
300 FORMAT ( (1HO, 39X, 13HALOFT , 8X, A4 , IX, F9 . 3, 6X, A4 , 5X, F"9 . 3
1,4X,A4,F9.3,4H PPM))
307 FORMAT (1HO,//,4OX,36HTRANSPORTED BIOGENIC CONCENTRATIONS /)
308 FORMAT ((1HO,39X,13HSURFACE LAYER,8X,A4,IX,F9.3,6X,A4,5X,F9.3
1,4X,A4,F9.3,4H PPM))
309 FORMAT ( (1HO, 39X, 1.3HALOFT ,8X,A4,IX,F9.3,6X,A4,5X,F9.3
1,4X,A4,F9.3,4H PPM))
310 FORMAT (1HO // 40X,70HCONTINUOUS EMISSIONS (EXPRESSED AS FRACTION
10F THE INITIAL PRECURSORS)
2 // 40X,7HSPECIES,5X,4HHOUR,5X,10I6 / 61X,1016 / 61X,1016)
311 FORMAT (1HO // 40X,39HBIOGENIC EMISSIONS (IN UNITS OF PPM/HR)
1 // 40X,7HSPECIES,5X,4HHOUR,5X,10I6 / 61X,1016 / 61X,10I6)
320 FORMAT (1HO // 40X,58HSURFACE DEPOSITION RATES (CM/SEC)
1 // 40X,14H
2 // 40X,7HSPECIES,5X,4HHOUR,5X,10I6 / 61X,1016 / 61X,10I6)
330 FORMAT (1HO,41X,A4,4X,8HFRACTION,4X,10F6.3 / 62X,10F6.3 /
1 62X,10F6.3)
331 FORMAT (1HO,41X,A4,16X,10F6.3,/,62X,10F6.3,/,62X,10F6.3)
340 FORMAT (1HO,41X,A4,4X,8HRATE ,4X,10F6.3 / 62X,10F6.3 /
1 62X,10F6.3)
350 FORMAT (1HO // 40X,58HCONTINUOUS EMISSIONS (EXPRESSED AS THE FRACTC
1ION OF INITIAL // 40X,50HNON-BACKGROUND NOX CONCENTRATION EMITTED C
2PER HOUR) // 45X,4HHOUR,3X,11I6 / 52X,4I6)
360 FORMAT (1HO // 40X,39HDILUTION DETERMINED FROM THE FOLLOWING // 4C
10X,49HINVERSION HEIGHTS (AT THE BEGINNING OF EACH HOUR) // 40X,4HHC
20UR,9X,1HO,,9I8 / 46X,10I8 / 46X, 1018)
370 FORMAT (1HO,39X,8HHEIGHT ,10F8.1 / 48X,10F8.1 / 48X,10F8.1)
380 FORMAT (1H1 // 4OX,26HTRANSPORTED CONCENTRATIONS )
390 FORMAT ((1HO,39X,13HSURFACE LAYER,3X,3(A4,9H FRACTION,F6.3,3X)))
391 FORMAT (1HO//40X, 60HTHE FOLLOWING BIOGENIC SPECIES ARE TREATED AC
IS HYDROCARBONS /40X,29H(EXPRESSED AS BOND FRACTIONS) )
392 FORMAT (1HO,39X,A4,12X,3(A4, 9H FRACTION, F6.3, 3X) ,/,
1 7<56X,3(A4,9H FRACTION,F6.3,3X),/))
400 FORMAT ((1HO,39X,6HALOFT ,10X,3(A4,9H FRACTION,F6.3,3X)))
410 FORMAT (1HO //40X,46HMIXING HEIGHTS (AT THE BEGINNING OF EACH HOURC
1) // 40X,4HTIME,2X,10I8/46X,10I8/46X,10I8)
420 FORMAT (1HO,39X,6HHEIGHT,2X,10F8.1/48X,10F8.1/48X,10F8.1)
C
C
vc
4C
1C
C
C
C
4C
OC
C
HC
C
C
FC
C
3C
C
TC
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
re
C
C
3C
-1C
C
C
C
C
\c
C
C
C
C
1C
C
C
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
162A
162B
162C
162D
162E
163
164
165
165A
165B
166
167
168
169
170
170A
171
172
173
174
175
176
177
178
179
180
181
181A
181B
181C
181D
182
183
184
185
C-4
-------
430 FORMAT { (1HO, 39X, 13HBACKGROUND
FRACTION F6 3 3YM
. -., k,rj.u.3,4H PPM)
450 FORMAT (1HO // 40X,43HTEMPERATURE (AT THE BEGINNING OF EACH
1 // 40X,4HHOUR,9X,1HO,9I8 / 46X,10I8 / 46X,10I8)
460 FORMAT (1HO,39X,8HTEMP ,10F8.1 / 48X,10F8.1 / 48X,10F8
470 FORMAT (1HO // 40Xf49HRELATIVE HUMIDITY (AT THE BEGINNING OF
1HOUR) // 40X,4HHOUR,9X,1HO,9I8 / 46X,10I8 / 46X,10I8)
480 FORMAT (1HO,39X,8HRH (%) ,10F8.1 / 48X,10F8.1 / 48X,10F8
490 FORMAT (1HO // 40X,52HWATER CONCENTRATIONS (AT THE BEGINNING
1CH HOUR) // 40X,4HHOUR,9X,1HO,9I8 / 46X,10I8 / 46X,10I8)
500 FORMAT (1HO,39X,8HPPM ,10F8.0 / 48X,10F8.0 / 48X
510 FORMAT (1HO,39X,8HPRESSURE,5X,F6.2,13H INCHES OF HG)
520 FORMAT
-------
SUBROUTINE MECH D i
SAVE D 2
C D 3
C SET DEFAULT MECHANISM CONDITIONS D 4
C D 5
COMMON /CALC/ NR,KR(200,12),A(200),S(200),R(200),ITYPE(200), D 6
1 IA(60),JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT, D 6A
2 TSTEP,ZENI D 7
COMMON /PHOTON/ CF(72,20),P(24,20),IPH(20),IP,RFCT(20),PP{10,20), D 8
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10), D 9
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300) D 10
COMMON /ZENITH/ IPZ,ZDEF(10,20),IPHZ(20),IZENP D 11
C D HA
COMMON /CALCHR/ SPECIS(61) D 11B
COMMON /PHTCHR/ ISPNCR(IO) D llc
C D 11D
CHARACTER* 4 SPEC IS D HE
c
c
D 12
C PLACE ZENITH ANGLE DEPENDENCE INTO APPROPRIATE SLOT FOR EACH REACTIOND 13
D 14
DO 40 K=1,IP D 15
DO 20 J=l, IPZ D 16
IF (IPH(K) .NE.IPHZ(J)) GO TO 20 D 17
DO 10 1=1,10 D 18
PP(I,K)=ZDEF(I,J) ' D 19
10 CONTINUE D 20
GO TO 40 D 21
20 CONTINUE D 22
DO 30 1=1,10 D 23
PP(I,K)=1.0 D 24
30 CONTINUE D 25
40 CONTINUE D 26
D 27
DO 50 1=1, IP D 28
J=IPH(I) D 29
RFCT(I)=A(J) D 30
50 CONTINUE D 31
D 32
RETURN D 3 3
END
D
D-l
-------
SUBROUTINE MCHSET (NX,NEPA) v
SAVE h 1
C E 2
C READ NEW MECHANISM ?, *j
C E 4
COMMON /CALC/ NR, KR (200, 12) , A(200) , S (200) , R (200) , ITYPE (200) , IA (60) E 6
•L , JA( 800) ,DILUT, TEMP, ERR, START. STOPP,TPRNT TSTEP ZENTF 7
COMMON /SPEC/ NSfCARB(20)fRCTY(20)fXNf(2),li(20),iNOX(2) ' E 8
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN, E 9
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5) E 10
COMMON /HEAT/ SC (200, 12) , ISC (200, 3) E T?
COMMON /NEED1/ IBLANK, MBLANK, IIHC, IINX, IICO, IIN02, UNO, 1103, E 12
1 IIH20,JPLUS P it
COMMON /STORE/ AST (60) £ |^
COMMON /INOUT/ IN, IOUT, ITAPE, IALN, IALL, INHH, IOZC E IS
COMMON /GEAR10/ IRS (200, 12) p ,?
COMMON /PHOTON/ CF (12, 20) , P (24 , 20) , IPH (20) , IP, RFCT (20) , PP ( 10, 20) E 17
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF{125,10), E 18
2 IDPTIMrDPEND,RDEPl(26,10),DNOWS,SPRSE(300) E 19
NS=1
E
E
COMMON /CALCHR/ SPECIS(61)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO) ,
COMMON /SPECHR/ HCSPEC(20), PLSP(5)f REACT (61) E 19E
*
CHARACTER*! JMINUS, AST
CHARACTER* 4 ISPDP
CHARACTER*4 SPECISf HCSPEC, PLSP, REACT
CHARACTERS IBLANKr MBLANK, II
1 IIH20, IBZA,JPLUS, E
, E 1 q
CHARACTERS IBLANKr MBLANK, IIHC, IINX, IICO, IIN02, IINO, 1103, E 19J
'
2 IPL, IRS, KRS, MORX
DIMENSION KRS(12),SC1(12),IPL(12) E 20"
DATA JMINUS/'-'/ ^ 21
ICOUNT=0 E 22
NR=0 E 23
MORX=IBLANK E 25
DO 10 1=1,200 I 2°
A(I)=0. E 27
S(I)=0. E 28
R(I)=0. E 29
DO 10 J=l,12 E 30
IRS(I,J)=IBLANK E 3l
IF (I.EQ.l) KRS(J)=IBLANK E ^2
SC(I,J)=1. . E 33
10 KR(I,J)=0 E 34
20 NS=NS-1 E 35
WRITE (IOUT,,200) E 36
30 IF (NEPA.LE.O) E 37
E 40
C CHECK FOR MORE PRODUCTS E 41
C E 42
IF (MORX. NE ..IBLANK. AND. NEP A. LE 0) p ^
1READ (IN,160) (SCI(II-3),KRS(II),11=7 12) v A\
IF {NEPA.GT.O) b
1READ (IN,170) J, (KRS (I),1 = 1,7),RTE,ENERGY * ^
IF (NEPA.GT.O) GO TO 50 .
IF (MORX.NE.IBLANK) GO TO 50 ' E 48
DO 40 11=7,12 E 49
E 50
E 51
E-l
-------
KRS(II)=IBLANK E 52
40 CONTINUE E 53
50 DO 60 11=1,12 E 54
60 IRS(J,II)=KRS(II) E 55
A(J)=RTE E 56
S(J)=ENERGY E 57
DO 70 11=4,12 E 58
70 SC(J,II)=SCl(II-3> E 59
80 DO 90 1=1,12 E 60
90 IF (ABS(SC(J,I)).EQ.O.) SC(J,I)=1. E 61
DO 120 K=l,12 E 62
NL=K*5 E 63
NF=NL-4 E 64
DO 100 LK=NF,NL E 65
100 AST(LK)=IB.LANK E 66
IPL(K)=IBLANK E 67
IF (IRS(J,K).EQ.IBLANK) GO TO 110 E 68
IPL(K)=JPLUS E 69
IF (K.EQ.1.0R.K.EQ.4) IPL(K)=IBLANK E 70
IF (SC(J,K).LT.O.) IPL(K)=JMINUS E 71
110 KK = K E 72
IF (IRS(J,K).NE.IBLANK) CALLVALU (SC(J,K),NF,NL) E 73
120 CONTINUE E 74
ICOUNT=ICOUNT+2 ' E 75
IF (IRS(J,8).NE.IBLANK) ICOUNT=ICOUNT+1 E 76
IF (IRS(J,12).NE.IBLANK) ICOUNT=ICOUNT+1 E 77
IF (ICOUNT.GT.50) WRITE (IOUT,200) E 78
IF (ICOUNT.GT.50) ICOUNT=2 E 79
WRITE (IOUT,180) E 80
1 J,IPL(1),(AST{I),1=1,5),IRS(J,1),IPL(2),(AST(I),1=6,10)E 81
2,IRS(J,2),IPL<3),(AST(I),I=11,15),IRS(J,3),IPL(4),(AST(I),1=16,20)E 82
3,IRS(J,4),IPL(5),(AST(I),1=21,25),IRS(J,5),IPL(6),(AST(I),1=26,30)E 83
4,IRS(J,6),IPL(7),(AST(I),I=31,35),IRS(J,7),A(J),S(J) E 84
IF (MORX .NE. IBLANK) E 85
1 WRITE (IOUT,190) IPL(8), (AST(I),1=36,40), E 86
2 IRS(J,8),IPL(9),51,55),IRS(J,11) E 89
IF (MORX.NE.IBLANK.AND.IRS(J,12).NE.IBLANK) E 90
1WRITE (IOUT,190) IPL (12), (AST(I),1=56,60),IRS(J,12) E 91
KR(J,1)=100 E 92
IF (IP.EQ.O) GO TO 140 E 93
DO 130 1=1,IP E 94
IF (J.NE.IPH(I)) GO TO 130 E 95
RFCT(I)=A(J) E gg
GO TO 140 E 97
130 CONTINUE . E 98
140 IF (J.GT.NR) NR=J E 99
IF (J.NE.NX) GO TO 30 E 100
CALL MATRX E 1Q1
RETURN E 1Q2
E 103
150 FORMAT (2(A4,2X),A4,13,F5.1,A4,Al,IX,2(F5.0,IX,A4,2X),F10.2,IX,F7.E 104
12) E 105
160 FORMAT (6(F5.0,IX,A4,2X)) E 106
170 FORMAT (13,2X,7(A4,IX),2F10.2) E 1Q7
180 FORMAT (/2X,13,IX,3(Al,5A1,IX,A4,2X),1H=,IX,3(Al,5A1,IX,A4,2X), E 108
1A1,5A1,1X,A4,3X,1PE11.3,2X,E13.3) E 109
190 FORMAT (45X, 2X, 4 (Al, 5A1, IX, A4, 2X) ) E no
200 FORMAT (1H1////1HO,14H THE REACTIONS,86X,13HRATE CONSTANT,2X,15HACE 111
IT. ENERGY(K) ) E 112
END
E-l
-------
KRS(II)=IBLANK
40 CONTINUE
50 DO 60 11=1,12
60 IRS(J,II)=KRS(II)
A(J)=RTE
S(J) -ENERGY
DO 70 11=4,12
70 SC(J,II)=SCl(II-3)
80 DO 90 1-1,12
90 IF (ABS(SC(J,I)).EQ.O.) SC(JfI)-l.
DO 120 K=l,12
NL=K*5
NF=NL-4
DO 100 LK=NF,NL
100 AST(LK)=IBLANK
IPL(K)=IBLANK
IF (IRS(J,K) .EQ.IBLANK) GO TO 110
IPL(K)=JPLUS
IF (K.EQ.1.0R.K.EQ.4) IPL (K) =IBLANK
IF (SC(J,K).LT.O.) IPL(K)=JMINUS
110 KK = K
120
(SC(J,K),NI
ICOUNT=ICOUNT+2
IF (IRS(J,8).NE.IBLANK) ICOUNT=ICOUNT+1
IF {IRS(J,12).NE.IBLANK) ICOUNT=ICOUNT+1
IF {ICOUNT.GT.50) WRITE (IOUT,200)
IF (ICOUNT.GT.50) ICOUNT=2
WRITE (IOUT,180)
r£ ^(}l'iA*T
-------
SUBROUTINE MATRX
SAVE
SET UP THE INTERNAL ARRAY FOR THE CURRENT CHEMICAL MECHANISM
COMMON /CALC/ NR,IR(200,12),A(200),S(200),R(200),ITYPE(200),IA(60)
1i JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT,TSTEP,ZENI
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20),
1 INOX(2),FINHC(20),FALHC(20),NHC,OZIN,OZAL,
2 HCIN,HCAL,XNIN,XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
COMMON /GEARI/ TTDUM(5),UROUND,NNDUM(4)
COMMON /HEAT/ SC(200,12),ISC(200,3)
COMMON /NEED1/ IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,1103,
1 IIH20,JPLUS
COMMON /STORE/ AST(60)
COMMON /GEAR10/ KR(200,12)
COMMON /CALCHR/ SPECIS{61)
COMMON /NEED1C/ IBZA
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*! AST
CHARACTERS SPECIS, HCSPEC, PLSP, REACT
CHARACTERS IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103,
1 IIH20,, IBZA, JPLUS,
2 KR, KCHR
NOLD=NS+1
DO 170 1=1,NR
c
c
c
c
c
c
c
c
c
c
c
c
SKIP REACTIONS
IF (IR(I, 2) .EQ.
IF (IR(I,2) .EQ.
IF (IR(I,1) .EQ.
IF (IR(I, 1) .EQ.
IF (IABS(IR(I,1
ALREADY PROCESSED
NOLD. OR. IR(I,
3) .EQ.NOLD) IR(I,3)=99
NOLD) IR(I,2)=0
NOLD) IR(I,1)
NOLD) IR(I, 3)
= 99
= 99
) ) .NE.100) GO TO 170
ZERO OUT REACTIONS;
DO 10 J=2,12
10 IR(I,J) = 0
IF LESS THAN THREE REACTANTS
IF (KR(I,1) .NE.
IF (KR(I,3) .NE.
IF (KR(I,3).NE.
SC(I,3)=1.
KR(I,3)=IBLANK
IF (KR(I, 1) .NE.
KR(I,1)=KR(I,2)
KR(I,2)=IBLANK
SC(I,1)=SC(I,2)
SC(I,2)=1.
20 IF (KR(I,2) .NE.
IF (KR(I,3) .NE.
SC(I,3)=1.
IF (KR(I,3) .NE.
KR(I,3)=IBLANK
30 DO 40 K=4, 12
GET RID OF M AS
, FILL FIRST SLOTS.
IBLANK) GO TO 20
IBLANK) KR(I,
IBLANK) SC(I,
IBLANK) GO TO
IBLANK) GO TO
IBLANK) SC(I,
IBLANK) KR(I,
A PRODUCT
1)=KR(I,3)
1)=SC(I,3)
20
30
2)=SC(I,3)
2)=KR(I,3)
F
F
F
F
F
)F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
F
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
16A
16B
16C
16D
16E
16F
16G
16H
161
16J
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
F-l
-------
IF
-------
IR(I,J)=NS F 119
160 CONTINUE F 120
170 CONTINUE F i2l
IF (SPECIS(NS).NE.MBLANK) NS=NS+1 F 122
SPECIS(NS)=MBLANK F 123
DO 180 IK=1,NR F 124
DO 180 MT=1,3 F 125
J=IFIX(SC(IK,MT)+UROUND) F 126
ISC(IK,MT)=J F 127
180 IF (SC(IK,.MT)-FLOAT (J) .GT. 4 . *UROUND) ISC (IK, MT) =-1 F 128
RETURN F 129
END F 130
F-3
-------
SUBROUTINE MCHWRT
SAVE
WRITE THE CURRENT MECHANISM TO OUTPUT FILE
COMMON
1'
COMMON
COMMON
COMMON
COMMON
COMMON
COMMON
1
2
/CALC/ NR,KR(200,12),A(200),S(200),R(200),ITYPE(200),
JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT,TSTEP
NS,CARS(20),RCTY(20),XNF(2),IH(20),INOX(2),
FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,
XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
SC(200,12),ISC(200,3)
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103
IIH20,JPLUS
AST(60)
IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
CF(72,20),P(24,20),IPH(20),IP,RFCT(20),PP(10
IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10)
IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
/SPEC/
/HEAT/
/NEEDI/
/STORE/
/INOUT/
/PHOTON/
COMMON /CALCHR/ SPECIS(61)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /SPECHR/ HCSPEC(20), PLSP (5), REACT(61)
CHARACTER*! JMINUS, AST
CHARACTER*4 ISPDP
CHARACTER*4 SPECIS, HCSPEC, PLSP, REACT
CHARACTER*4 IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103
1 IIH20, IBZA,JPLUS,
2 KRS, I?L
DATA JMINUS/'-'/
ICOUNT=0
WRITE (IOUT,110)
DO 50 J=1,NR
IR=KR(J,1)
IF (IR.EQ.O.OR.A(J).EQ.O.) GO TO 50
DO 10 1=1,12
II=KR(J,I)
IF (II.GT.O)
IF -(II.LE.O)
10 CONTINUE
KRS(I)=SPECIS(II)
KRS(I)=IBLANK
DO 40 K=l,12
NL=K*5
NF=NL-4
DO 20 LK=NFrNL
20 AST(LK)=IBLANK
IPL(K)=IBLANK
IF (KRS(K).EQ.IBLANK) GO TO 30
IPL(K)=JPLUS
IF (K.EQ.1.0R.K.EQ.4) IPL(K)=IBLANK
IF (SC(J,K).LT.O.) IPL(K)=JMINUS
30 KK = K
IF (KRS(K).NE.IBLANK) CALLVALU (SC(J,K),NF,NL)
40 CONTINUE
ICOUNT=ICOUNT+2
IF (KRS(8).NE.IBLANK) ICOUNT=ICOUNT+1
IF (KRS (12) ..NE.IBLANK) ICOUNT=ICOUNT + 1
IF (ICOUNT.GT.50) WRITE (IOUT,110)
IF (ICOUNT.GT.50) ICOUNT=2
G
G
G
G
G
IA(60)G
',ZENI G
XNIN
r
,20)
r
G
, G
G
G
G
G
G
G
, G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
G
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
ISA
18B
18C
18D
18E
18F
18G
18H
181
18J
18K
18L
18M
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
G-l
-------
WRITE (IOUT,90) G 52
1 J,IPLU), (AST(I),I=1,5),KRS(1),IPL(2), (AST(I),1=6,10), G 53
2KRS(2),IPL(3),(AST(I),I=11,15),KRS(3),IPL(4),(AST(I),1=16,20), G 54
3KRS(4),IPL(5),(AST(I),I=21,25),KRS(5),IPL(6),(AST(I),1=26,30), G 55
4KRS(6),IPL(7),(AST(I),I=31,35),KRS(7),A(J),S(J) G 56
IF (KRS(8) .NE. IBLANK) G 57
1 WRITE (IOUT,100) IPL(8),(AST(I),1-36,40), G 58
2 KRS{8),IPL(9),(AST(I),I=41,45),KRS{9), G 59
3 IPL(IO),(AST(I),I=46,50),KRS{10), G 60
4 IPL(ll),(AST(I),I=51,55),KRS(11) G 61
IF (KRS(12).NE.IBLANK) G 62
1WRITE (IOUT,100) IPL(12),(AST(I),1=56,60),KRS(12) G 63
50 CONTINUE . G 64
RETURN G 65
G 66
60 FORMAT (2(A4,2X),A4,I3,F5.1,A4,A1,1X,2(F5.0,1X,A4,2X),F10.2,1X,F7.G 67
12> G 68
70 FORMAT (6{F5.0,IX,A4,2X)) G 69
80 FORMAT (I3,2X,7(A4,IX),2F10.2) G 70
90 FORMAT
-------
SUBROUTINE MIXST
SAVE
SETUP MIXING HEIGHTS BASED ON MORNING AND AFTERNOON VALUES
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM,ID,
COMMON /CNTRL/
ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),
XZ(24),K(24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,MAXJH
SIG,SIGMA,INFO,NPTO,TSRT,DTIM,Z1,Z2,DCON,EHC,EXN,
1 FLST,TLST
COMMON /MIXING/ DSTRT,DEND,A(5),B(5),C(5),FD(6),Y(6),AMIX(26),DL,
1 TTMAX,SRISE,HMIN,DELH,TOIL,NMIX,HTT,SSET,SSRISE
INTEGER PSPEC
DETERMINE TIME OF SUNRISE (STANDARD TIME)
10
T=400.
CALL SOLAR(SLA,SLO,TZ,IY,IM,ID,T,D,5)
IF(D.GE.l.) GO TO 20
T=CLOCK(T,5)
GO TO 10
CONVERT SUNRISE TO LOCAL DAYLIGHT TIME
20 TSR=T
IF(TSR.LT.0600.)
TSR=0600.
DETERMINE SOLAR DECLINATION AND DAY LENGTH
CALL SOLAR{SLA,SLO,TZ,IY,IM,ID,1200.,D,l)
0=0*3.14159/180.
ARG1=-TAN(0.67399}*TAN(D)
DL-ACOS(ARGl)73.14159*1440.
IDL=DL
TSS=CLOCK(TSR,IDL)
COMPUTE TIME MAXIMUM HEIGHT IS REACHED
TMAX=.70*DL
ITMAX=TMAX
TTMAX=CLOCK(TSR, ITMAX)
CONVERT ALL, 2400 HOUR TIMES TO MINUTES AFTER SUNRISE
SRISE=(FLOAT(IFIX(TSR/100.))*60.)+
1 (TSR-(FLOAT(IFIX(TSR/100.))*100.))
DDSTRT=(FLOAT(IFIX(DSTRT/100.) )* 60 .) +
1 (DSTRT-(FLOAT(IFIX(DSTRT/100.))*100.))
DDEND=(FLOAT(IFIX(DEND/100.))*60.)+
1 (DEND-(FLOAT{IFIX(DEND/100.))*100.))
DDSTRT=DDSTRT-SRISE
DDEND=DDEND-SRISE
COMPUTE HMIN AND DELTA HEIGHT
FD1=DDSTRT/DL
FD2=DDEND/DL
DO 30 J=l,5
IF(FD1.GE.FD(J).AND.FD1.LT.FD{J+l)) II=J
IF(FD2.GE.FD(J).AND.FD2.LT.FD(J+l)) JJ=J
J1=JJ
30 CONTINUE
IF(FDl.GE.O.O) GO TO 40
FD1=0.0
H
H
H
H
H
H
H
CJH
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
H
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
H-l
-------
= H 65
40 IF(FD2.LT.0.70) GO TO 50 H 66
FD2=.7 H 67
JJ-6 H 68
Jl=5 H 69
50 CONTINUE H 70
X=FD1-FD(II) H 71
XX=FD2-FD(JJ) H 72
FG1=((A(II)*X+B(II))*X+C(II))*X+Y(II) H 73
FG2=((A(J1)*XX+B(J1))*XX+C(J1))*XX+Y(JJ) H 74
DELH=(Z2-Z1)/(FG2-FG1) H 75
HMIN=Z1-FG1*DELH H 76
HMAX=HMIN+DELH H 77
H 78
COMPUTE MIXING HEIGHTS AT HOURLY INTERVALS H 79
H 80
NMIX=0 H 81
JJSTP=JSTOP-100 H 82
IT=JSTRT/100 H 83
T=IT*100 H 84
IF (DEND.GT.TTMAX) DEND=TTMAX H 85
DO 110 J=l,26 H 86
IF(T.LT.DSTRT) GO TO 80 H 87
IF(T.GE.DEND) GO TO 90 H 88
TT=(FLOAT(IFIX(T/100.))*60.) + (T-(FLOAT(IFIX(T/100.)))* 100.) H 89
TT=TT-SRISE H 9Q
FDT=TT/DL H gi
IF (FDT.LT.0.0) FDT=0.0 H 92
KK=0 H 93
60 KK=KK+1 H 94
IF(FDT.GE.FD(KK).AND.FDT.LT.FD(KK+1)) GO TO 70 H 95
IF(KK.LT.S) GO TO 60 H 96
IF(FDT.GE.FD(6)) GO TO 90 H 97
70 CONTINUE H 9Q
X=FDT-FD(KK) H 99
FG=((A(KK)*X+B(KK))*X +C(KK))*X+Y(KK) H 100
AMIX(J)=HMIN+FG*DELH H
NMIX=NMIX+1 H
IF (T.GE.FLOAT(JJSTP)) GO TO 120 H 103
GO TO 100 H 1Q4
80 AMIX(J)=Z1 H 1Q5
NMIX=NMIX+1 H log
GO TO 100 H 1Q7
90 AMIX(J)=Z2 H 1Q8
NMIX=NMIX+1 H log
100 CONTINUE H 11Q
T=T+100. H ,,,
110 CONTINUE H 112
120 CONTINUE H U3
IF(DEND.GT.TTMAX) DEND=TTMAX H 114
RETURN H n5
END H 116-
H-2
-------
c
c
c
— • " —»»»^ v j. .k 1«.|_J AXZ1 A i_lW \ %* f il /
SAVE
SETUP RATE CONSTANTS FOR THE CURRENT CHEMICAL MECHANISM
I
I
I
I
COMMON /CALC/ NR, KR (200, 12) , A(200) , S (200) , R (200) , ITYPE (200) , IA (60) I
A™*,™ ,„„ . JA(800)'DILUT'TE^'ERR/START,STOPP,TPRNT,TSTEP,ZENI I
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2>, I
1 FJ_NHC<20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN. I
C
C
C
c
^ XNAL,NOZ,FENX(2),CR(61),NI,KOZ{5)
COMMON /CALCHR/ SPECIS (61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT (61)
DIMENSION C(l)
DIMENSION SIG(61)
CHARACTER*4 SPECIS, REACT, HCSPEC, PLSP
FCT= ( 1 . /298 . ) - ( 1 . /TEMP )
DO 10 1=1,51
10 SIG(I)=0.
IF (N.LE.O) GO TO 40
DO 30 1=1, N
DO 20 J=1,NS
IF (SPECIS (J) .EQ.REACT(I)) SIG(J)=C(I)
IF (SPECIS ( J) .EQ. REACT (I)) GO TO 30
20 CONTINUE
SIG(NS+1)=SIG(NS+1)+C(I)
30 CONTINUE
40 N=NS
M=N-1
C(N)=0.
DO 50 1=1, M
C(N)=C(N)+SIG(I)
50 C(I)=SIG(I)
BK=0.
C(N)=C(N)+SIG(NS+1)
IF (SIG(N) .NE.O.) BK=SIG(N)-C(N)
IF (SIG(N) .NE.O.) C(N)=SIG(N)
NP=0
DO 70 1=1, NR
IF -7
40
T W
41
42
43
44
A C
4 b
46
A ~7
4 /
48
A d
4 y
50
51
52
53-
1-1
-------
SUBROUTINE SPARS (IA,JA,N)
SAVE
C
C SETUP INTERNAL GEAR POINTER VECTOR
C
COMMON /CALC/ NR,KR(200f12),A(200),S(200),R(200)
I/ JB(800),DILUT,TEMP,ERR,START,STOPP
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20)
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ{5)
,ITYPE(200),IB(60)J
,TPRNT,TSTEP,ZENI J
,INOX(2),
HCINrHCAL,XNIN,
COMMON /CALCHR/ SPECIS(61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT (61)
CHARACTER*^ SPECIS, HCSPEC, PLSP, REACT
DIMENSION IA(N), JA(N)
DO 10 1=1, N
10 IA(I)=1
KT=0
JA(1)=0
DO 140 IR=1,NR
IF (KR(IR, 1) .EQ.O.OR.KRdR, 1) .EQ.99) GO TO 140
MT=ITYPE(IR)
DO 130 K=1,,MT
I=KR(IR,K)
DO 60 L=1,MT
J=KR(IR,L)
K1=IA(J)
K2=IA(J+1)-1
IF (K1.GT.K2) GO TO 30
DO 20 M=K1,K2
IF (I.EQ.JA(M) ) GO TO 60
20 CONTINUE
30 DO 40 M=J,N
40 IA(M+1)=IA(M+1)+1
KT=KT+1
KD=KT-K2
K2=K2+1
DO 50 M=1,KD
KTM = KT-M
JA(KTM+2) = JA(KTM+1)
50 CONTINUE
JA(K2)=I
60 CONTINUE
K1=IA(I)
DO 120 L=4,12
J=KR(IR,L)
IF (J) 120,130,70
70 IF (K1.GT.K2) GO TO 90
DO 80 M=K1,K2
IF (J.EQ.JA(M)) GO TO 120
80 CONTINUE
90 DO 100 M=I,N
100 IA(M+1)=IA(M+1)+1
KT=KT+1
KD=KT-K2
K2=K2+1
DO 110 M=1,KD
KTM = KT-M
JA(KTM+2) = JA(KTM+1)
110 CONTINUE
J
J
J
J
J
) J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
J
1
2
3
4
5
6
7
8
9
10
10A
10B
IOC
10D
10E
10F
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
J-l
-------
JA(K2)=J
120 CONTINUE *! **
130 CONTINUE J *°
140 CONTINUE J "
DO 160 1=1,N "I "
T "
1 "I *l
IF (K1.GT.K2) GO TO 160 T ^
MT=K2-K1+1 I. **
DO 150 K=1,MT JT *'
DO 150 M=K1,K2 j gg
IF (JA(M).GT.JA(M-l)) GO TO 150 T -Jn
J-JA(M-l) JT '°
JA(M-1)=JA(M) T ':.
JA(M)=J ^ ^
150 CONTINUE 6
160 CONTINUE J. ll
M=N J 75
DO 190 1=1,M ' j ^
IF(IA(I+1) .GT.IA(I)) GO TO 190 T -,L
NM-I + 1 J If
NN=N+1 J ^
KMIN=IA(NM) ""
KMAX=IA(NN) j ^
DO 170 J=KMIN,KMAX T ^
KM=KMAX+KMIN-J , **
170 JA(KM)=JA(KM-1) T ^
KNOW=IA(I) JT ^
JA(KNOW)=I ° °°
DO 180 LL=NM,NN , *'
180 IA(LL)=IA(LL)+1 T ^
190 CONTINUE I. "^
RETURN I. ^°
END J 92-
J-2
-------
SUBROUTINE CONVT (NUM,L,N)
SAVE
SUBROUTINE CONVT CONVERTS INTEGERS TO ALPHANUMERICS
FOR PRINTING
ASSUMES VALUE OF INTEGER IS POSITIVE
DIMENSION L{5), JDIGIT(IO)
CHARACTER*! JDIGIT, JBLANK, L
DATA JDIGIT/'0', 'L','2','3','4','5','6','7','8','9'/
DATA JBLANK/' '/
NI=NUM
DO 10 1=1,N
L(I)=JBLANK
10 CONTINUE
DO 20 K=1,N
I=N-K+1
NEXT=NI/10
NDX=(NI-NEXT*10)+1
L(I)=JDIGIT(NDX)
IF (NEXT.LE.O) GO TO 30
NI=NEXT
20 CONTINUE
30 RETURN
END
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
K
1
2
3
4
5
6
7
8
9
10
10A
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29-
K-l
-------
SUBROUTINE VALU (VAL,NF,NL)
SAVE
•^
: CONVERT NUMERIC VALUES TO ALPHAS (ONLY USED TO WRITE MECHANISM)
COMMON /STORE/ AST(60)
^ . COMMON /GEAR1/ T,H,HMIN,HMAX,EPS1,UROUND,NC,MF1,KFLAG1,JSTART
*
DIMENSION AC(5), AD(5), BC(5)
CHARACTER*]. IBLK, IPER, IZRO, IW, AC, AD, BC, AST
DATA IBLK/' '/,IPER/'.'/,IZRO/'0'/
*
VAL1=ABS(VAL)
AVAL=ALOG10(VAL1)
IF (AVAL.EQ.0.) RETURN
DO 10 1=1,5
AC(I)=IBLK
AD(I)=IZRO
10 BC(I)=IZRO
IAD=IFIX(AVAL+UROUND)
IF (IAD) 60,20,20
20 IREM=3-IAD
IAD=IAD+1
JREM=IFIX(VAL1+UROUND)
REM=VAL1-FLOAT(JREM)
IF (REM.GT.UROUND.AND.IREM.GT.O) GO TO 30
CALL CONVT (JREM,AC,5)
GO TO 100
30 CALL CONVT (JREM,AD,IAD)
JREM=IFIX(REM*(10.* *IREM)+0.1)
CALL CONVT (JREM,BC,IREM)
DO 40 J=l,IAD
40 AC(J)=AD(J)
AC(IAD+1)=IPER
DO 50 K=1,IREM
KIAD1 = K+IAD+1
AC(KIAD1)=BC(K)
50 CONTINUE
GO TO 80
60 IAD=IABS(IFIX(AVAL-0.1))-1
IVAL=IFIX(VAL1*10000.+0.1)
CALL CONVT (IVAL,AC,5)
AC(1)=IPER
IF (ABS(VAL1+UROUND-0.1).LT.0.00001) GO TO 80
DO 70 1=1,IAD
70 AC(I+1)=IZRO
80 IF (AC(5).NE.IZRO) GO TO 100
DO 90 K=l,4
L=6-K
90 AC(L)=AC(L-1)
IF (AC(1) .EQ.IPER) IW=IZRO
IF (AC(1) .NE.IPER) IW=IBLK
AC(1)=IVV
GO TO 80
100 DO 110 I=NF,NL
K=I-NF+1
110 AST(I)=AC(K)
RETURN
END
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
L
1
2
3
4
5
6
7
7A
8
9
10
10A
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57-
L-l
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
SUBROUTINE EMISS (N,H,COEFF)
SAVE
TO HANDLE MORE THAN 16 HISTOGRAM INTERVALS (ASSUMING N IS #INTERVALS)
THE DIMENSIONED VARIABLES BELOW MUST HAVE THE FOLLOWING DIMENSIONS
H = N; Y,DYDX = N+l; CF,COEFF = 5*N
SEE ALSO DIMENSION STATEMENT IN STAIR
DIMENSION H(25), CF(125), Y(26), DYDX(26), COEFF(125)
DOUBLE PRECISION CF, Y, DYDX, HRATIO, EXPONE, FORRAT, FORCDY
DOUBLE PRECISION SIGNDY, SMALLV, RATLIM
REAL DELX, H, COEFF
INTEGER STARTY, STOPY, INDEX, N, MODE, MODE1I
INTEGER NPLUS1, FIVEN, J, K
N IS THE NUMBER OF HISTOGRAM INTERVALS
N+l IS THE NUMBER OF EDGES IN THE HISTOGRAM PLOT
RATLIM= 5.001
MODE=1
DELX=1.0
FORRAT= 2.5
FORCDY =5.25
NPLUS1 = N + 1
FIVEN = 5 * N
IF ( FIVEN .LE. 1) GO TO 20
DO 10 J = 1 , FIVEN
SET ALL COEFFICIENTS TO ZERO IN THE CF ARRAY.
CF(J) =0.0
10 CONTINUE
20 CONTINUE
IF ( NPLUS1 .LE. 1) GO TO 40
DO 30 J = 1 , NPLUS1
ZERO OUT ALL THE Y' S AND DYDX'S, IN THE PROCESS
FORCING THE EDGE OF THE LAST DELX INTERVAL TO ZERO
Y(J) = 0.0
DYDX(J) =0.0
LOOK FOR THE FIRST NON-ZERO H
30 CONTINUE
40 CONTINUE
INDEX = 1
WHILE ((H(INDEX) . LE . 0.0) .AND. (INDEX .LT. N) )
50 IF ((H(INDEX) .GT. 0.0) .OR. (INDEX . GE . N) ) GO TO 60
INDEX = INDEX + 1
GO TO 50
60 CONTINUE
STARTY = INDEX
INDEX = INDEX + 1
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
M-l
-------
MODE1I = 1
C IF (MODE .NE. 0)
IF (MODE .EQ. 0) GO TO 70
C THEN
MODE 11 = START Y
Y(STARTY) = H(STARTY)
DYDX(STARTY) - 0.0
70 CONTINUE
C
C ..
C STAIR DETERMINES THE COEFFICIENTS OF THE FOURTH DEGREE
C POLYNOMIAL F(X) = ( ( (AX+B) X+C) X+D) X+E SUCH THAT F(X) IS
C TWICE DIFFERENT-TABLE ACROSS HISTOGRAM INTERVAL EDGES
C MATCHES IN VALUE AT THE INTERVAL EDGES, AND SUCH THAT
C THE INTEGRAL OF F(X)DX = THE HISTOGRAM INTERVAL HEIGHT
C TIMES THE INTERVAL WIDTH (DELX) . THE CROSSOVER POINTS
C (THE VALUES OF F(X) AT THE EDGES BETWEEN TWO HISTOGRAM
C INTERVALS) ARE THE KNOWNS . STAIR SOLVES FOR THE VALUES
C OF F' (X) AT THE EDGES GIVEN THE BOUNDARY CONDITIONS OF
C F' (X) AT THE TWO ENDS OF EACH STAIR EVALUATION. HISFIT
C STEPS THROUGH THE HISTOGRAM IN ONE PASS, BREAKING THE
C HISTOGRAM INTO STAIR EVALUATIONS OF 1 OR MORE INTERVALS
C NOTE THAT THE CURVE DEFINED BY THE COEFFICIENTS IS ONLY*
C ONCE DIFFERENTIABLE AT EDGES BETWEEN STAIR EVALUATIONS
C STAIR EVALUATIONS MAY NOT CROSS POINTS WHERE F' (X) IS
C KNOWN OR FIXED E.G. ZERO POINTS (DY/DX =0), OR FORCE
C FITS (WHERE UNRESTRAINED STAIR FITS RESULT IN FUNCTIONS
C WITH NEGATIVE VALUES WHICH CORRESPONDS TO NO PHYSICAL
C REALITY) . AT THESE EDGES, THE CURRENT STAIR EVALUATION
C IS TERMINATED AND A NEW STAIR EVALUATION STARTED IF
C THE RATIO OF ADJACENT HISTOGRAM VALUES IS LESS THAN 5/1
C A CROSSOVER POINT IS PICKED ACCORDING TO THE HEURISTIC-
C Y = (RATIO ** 0. 50 )M SMALLER VALUE)
r !!u?2S .;°01
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
LOOK FOR NEXT NON ZERO H
WHILE ((H(INDEX) .LE. 0.0) .AND. (INDEX .LT. N) )
90 IF ((H(INDEX) .GT. 0.0) .OR. {INDEX .GE. N) )
1 GO TO 100
INDEX - INDEX + 1
GO TO 90
100 CONTINUE
START NEW STAIR EVALUATION
STARTY = INDEX
GOTO BOTTOM OF LOOP
GO TO 230
IT IS GUARANTEED THAT H(INDEX-l) AND H( INDEX) ARE . GT . 0.0
110 CONTINUE
ELSE
HRATIO = H( INDEX) / H(INDEX-l)
EXPONE= 0.50
IF (HRATIO .GE. 1.0)
IF (HRATIO .LT. 1.0) GO TO 160
THEN
BEGIN UP STEP
SIGNDY =1.0
SMALLV= H ( INDEX- 1)
IF ((INDEX .EQ. (MODE1I +1)) .AND. (MODE .EQ. 0))
IF ((INDEX .NE. (MODE1I + 1)) .OR. (MODE .NE. 0))
1 GO TO 120
THEN
EXPONE =0.57
GO TO 15 C
120 CONTINUE
ELSE
IF .NOT. ((INDEX .EQ. 2) .AND. (MODE .NE. 0))
IF ({INDEX .EQ. 2) .OR. (MODE .NE. 0)) GO TO 140
THEN
IF (HUNDEX-2) . EQ . 0.0)
IF (H(INDEX-2) .NE. 0.0) GO TO 130
THEN
EXPONE =0.57
130 CONTINUE
140 CONTINUE
150 CONTINUE
GO TO 200
END UP STEP
• M
M
• - - M
M
M
M
M
M
M
M
M
- - M
M
- - M
M
M
M
- - M
M
- - M
M
M
M
- - M
M
- - M
M
M
M
M
M
M
M
M
M
- - M
M
- - M
M
M
M
M
M
M
M
.M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
M
- - M
M
- - M
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
M-3
-------
160
C
C
C - -
CONTINUE
ELSE
C BEGIN DOWN STEP
C
C
C
C
170
C
C
C
180
190
C
Q _
C END
r*
C
200
C
C
C
210
220
C
C - - -
HRATIO = 1.0 / HRATIO
SIGNDY = -1.0
SMALLV= H( INDEX)
IF (INDEX .EQ. N)
IF (INDEX .NE. N) GO TO 170
THEN
EXPONE =0.57
GO TO 190
CONTINUE
ELSE
IF (H(INDEX+1) .EQ. 0.0)
IF (H(INDEX+1) .NE. 0.0) GO TO 180
THEN
EXPONE =0.57
CONTINUE
CONTINUE
DOWN STEP
CONTINUE
IF (HRATIO .LT. RATLIM)
IF (HRATIO .GE. RATLIM) GO TO 210
THEN
Y{ INDEX) = (HRATIO ** EXPONE) * SMALLV
GO TO 220
ELSE
CONTINUE
Y( INDEX) = FORRAT * SMALLV
DYDX( INDEX) = SIGNDY * FORCDY * (Y ( INDEX) / DELX)
STOPY = INDEX
CALL STAIR ( STARTY, STOPY, DELX, H, Y, DYDX, CF)
STARTY = INDEX
CONTINUE
C BOTTOM OF LOOP, EXAMINE NEXT INTERVAL
C------ __
C
230
240
C
C
C
C FOR
C
C
C
1
C
CONTINUE
INDEX = INDEX + 1
GO TO 80
CONTINUE
ENDWHILE (INDEX .LE. N) LOOP
_
THE FINAL SPLINE PORTION, CALL STAIR.
IF (STARTY .NE. (N+l)) .AND. (H(N) . NE 00)
IF ((STARTY .EQ. (N+l)) .OR. (H(N) . EQ 0 0))
GO TO 250
THEN
STOPY = N + 1
CALL STAIR (STARTY, STOPY, DELX, H, Y, DYDX, CF)
M 193
M 194
M 195
M 196
M 197
M 198
M 199
M 200
M 201
M 202
M 203
M 204
M 205
M 206
M 207
M 208
M 209
M 210
M21 i
£. ± ±.
M 212
MO 1 "3
£. ± O
M 214
M 215
M 216
M 217
M 218
M 219
M 220
M 221
M 222
M 223
M 224
M 225
M 226
M 227
M 228
M 229
M 230
M 231
M 232
M 233
M 234
M 235
M 236
M 237
M 238
M 239
M 240
M 241
M 242
M 243
M 244
M 245
M 246
- - - M 247
M 248
- - - M 249
M 250
M 251
M 252
M 253
M 254
M 255
M 256
M-4
-------
250 CONTINUE M 25?
IF (1 .GT. FIVEN) GO TO 270 M 258
DO 260 K * 1 , FIVEN M 259
COEFF(K) = CF(K) M 260
260 CONTINUE M 261
270 CONTINUE M 262
RETURN M 263
END M 264-
M-5
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
~~u^»v, j. j.,.,^ ^ ±nj.f\ XIXOAIM , IVOlUr , UtJjA, H. I.lJlUX.CF)
SAVE
TO HANDLE MORE THAN 16 HISTOGRAM INTERVALS (ASSUMING N IS tINT
THE DIMENSIONED VARIABLES BELOW MUST HAVE THE FOLLOWING DIMENS
H = N; Y,DYDX,A,B,C = N+l; CF = 5*N
SEE ALSO DIMENSION STATEMENT IN HISFIT
J.VJN t\(£.v)r D (/.v) f C(26), CF(125), Y(26). DYDX(26),
DOUBLE PRECISION A, B C R SI S2 Tl T2 Ul U2 VI
DOUBLE PRECISION Y, DYDX, CF ' ' ' '
REAL DELX, H
INTEGER K, KSTRT, KSTOP, KSTOP 1, Jl, J2
INTEGER KSTOP2, KDOWN, KSTRT1
KSTOP 1 = KSTOP - 1
COMPUTE COEFFICIENTS FOR
FK(X)=AK(X-XK)4 + BK (X-XK) 3 + CK (X-XK) 2 + DK (X-XK) +EK
STORE IN ARRAY CF AS:
CF 5*K =A; CF 5*K-1 =B; CF 5*K-2 =C-
CF 5*K-3 =D=YKP CF 5*K-4 =E=YK
CF 5*K-3 =D=YKP CF 5*K-4 =E=YK
FOR K=KSTRT TO KSTOP (WHERE KSTOP-KSTRT IS THE NUMBER
OF INTERVALS. )
KSTRT IS THE LEFT EDGE OF THE STARTING HISTOGRAM BAR
KSTOP IS THE RIGHT EDGE OF THE STOPPING HISTOGRAM BAR
IF (KSTRT .GT. KSTOP 1) GO TO 20
DO 10 K = KSTRT , KSTOP 1
CF(5*K-4)=Y(K)
10 CONTINUE
20 CONTINUE
SET UP AND SOLVE MATRIX
B (KSTRT) =0.0
C (KSTRT) =0.0
IF ( KSTRT .GT. KSTOP 1) GO TO 70
DO 60 K = KSTRT , KSTOP 1
J2=K+1
U2=1.0/(DELX)
A(K)=U2
V2=U2*U2
S2=20.0*V2*H(K)
T2=8.0*V2*(Y{K)+Y(J2))
IF (K.GT. KSTRT)
IF (K.LE. KSTRT) GO TO 50
THEN
Z=1.0/{3.0*{U1+U2)+U1*B{J1)>
B(K)= -U2*Z
R=S2-Sl-T2+Tlf4 .0* (V1-V2) *Y(K)
IF (K.EQ.KSTRT+1)
IF (K.NE.KSTRT+1) GO TO 30
THEN
R=R+U1 *DYDX (KSTRT)
30 CONTINUE
IF (K.EQ. KSTOP 1)
N
N
N
N
ERVALS ) N
IONS N
N
N
N
H(25) N
N
N
N
LV
N
N
N
N
N
N
N
N
L»
N
N
N
N
N
- - - N
N
N
N
N
- - - N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
1
2
3
4
5
6
8
9
10
11
1 O
L£
13
14
1 C
1 D
1 &
X D
17
18
19
20
21
22
23
•O A
^ 4
25
26
27
? Q
JL b
29
30
31
32
-3 -3
-3 J
-5 A
34
35
36
37
38
39
40
41
42
43
44
A C
4 D
46
47
48
49
50
51
52
53
54
55
C £
D b
57
C Q
O O
59
60
61
s- *\
62
63
64
N-l
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
IF (K.NE.KSTOP1) GO TO 40
THEN
R=R+U1*DYDX {KSTOP)
40 CONTINUE
C{K)=Z*(R+U1*C(J1))
50 CONTINUE
J1=K
U1=U2
V1=V2
S1=S2
T1=T2
60 CONTINUE
70 CONTINUE
BACK SUBSTITUTION
IF (KSTOP-KSTRT.GT.l)
IF (KSTOP-KSTRT.LE.l) GO TO 100
THEN
DYDX (KSTOP-1 ) =C (KSTOP-1)
KSTOPP=KSTOP-1
CF (5*KSTOPP-3) =DYDX(KSTOPP)
IF (KSTOP-KSTRT.GT.2)
IF (KSTOP-KSTRT.LE.2) GO TO 90
THEN
KSTOP2 = KSTOP - 2
KSTRT1 = KSTRT + 1
DO 80 K = KSTRT1 , KSTOP2
KDOWN = KSTRT1 + KSTOP 2 - K
DYDX (KDOWN) = C (KDOWN) - B (KDOWN) * DYDX (KDOWN+1 )
CF(5*KDOWN-3) = DYDX (KDOWN)
80 CONTINUE
90 CONTINUE
100 CONTINUE
CF ( 5 *KSTRT-3 ) =DYDX (KSTRT)
COMPUTE 2ND, 3RD, 4TH ORDER COEFFICIENTS
IF ( KSTRT .GT. KSTOP 1) GO TO 120
DO 110 K = KSTRT , KSTOP 1
J2=K+1
Z=A(K)
CF(5*K-2)= 1.5*Z*(-3.0*DYDX(K) + DYDX(J2) + Z* (-8 0*
1 Y(J2) - 12.0*Y(K) + 20.0*H(K)»
CF(5*K-1)= -4.0*Z*Z*(-1.5*DYDX(K) + DYDX(J2) + Z*(-7 0*
1 Y(J2) - 8.0*Y(K) +15.0*H(K)»
CF(5*K) = 5.0*Z*Z*Z*(0.5*(DYDX(J2)-DYDX(K)) - 3.0*Z*
1 (Y(J2) + Y(K) - 2.0*H(K) ))
110 CONTINUE
120 CONTINUE
RETURN
END
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
- - N
- - N
N
- - N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
- - N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
i A /"\
1 U U
102
103
104
105
106
107
108
109
110
111
110
-LIZ
113
114
115
116
117
118
X X VJ
119
u
121
122-
N-2
-------
SUBROUTINE PHOT
SAVE ° 1
C 02
C **** RATE CONSTANT CALCULATIONS FOR FIRST ORDER PHOTOCHEMICAL 0 4
REACTIONS j!
C REF: SCHERE AND DEMERJIAN (1977) 06
W
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM, ID, 0 8
1 ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24), 0 9
rnMMOM /ou,vrnM/ ^!^)'K{24)'JSTRT'JSTOP'SPEC,MNLM,MXLM,MAXL,MAXJ 0 10
COMMON /PHOTON/ CF(72,20),P(24,20),IPH(20),IP,RFCT(20),PP(10,20), 0 11
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10) 0 12
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300) 0 13
TSTD=TIME
IF (L.EQ.l) CALL SPLNA (MAXZ,Z,RTCON,2,D,C,W)
IF (L.GT.l) CALL SPLNA (10,Z,PP(1,L),2,D,C,W) 0
u
COMMON /PHTCHR/ ISPDP(IO) ~
CHARACTERS ISPDP ^
INTEGER SPEC ° 13D
DIMENSION D(2), C(72), W(72), V(5), TMS(25) n JR
DATA D/0.,C)./ n !c
C 016
IEND=24 ° 17
NTM=IEND ' 0 l8
TIME=JSTRT
c D° 10 H-lrlEND °Q H
C **** CALL SUBROUTINE TO COMPUTE ZENITH ANGLES FROM TIME OF DAY 0 23
XC=0.0 ° 24
0 25
IF (TSTD.LT.O.) TSTD=TSTD+2400. 0 91
CALL SOLAR (SLA,SLO,TZ,IY,IM,ID,TSTD,XC,5) O 7fl
ITIME(II)=TIME n
XZ(II)=90.-XC 0 29
TIME=CLOCK(TIME,IINC) Q 3"
0 32
10 CONTINUE ' 0 33
0 34
DO 30 L=l,IP ° 35
ISTRT=(MNLM-LAM1)/INC+1 ? ^
ISTOP=(MXLM-LAM1)/1NC+1 ? 3]
C U 38
C **** f!AT.T. P"TPCT cnnorinT'Txir' 1-1^0 ^m TI-FT-, -r,, .
50
0
0
c CALL FIRST SUBROUTINE FOR SPLINE INTERPOLATION OF RATE CONSO 40
DO 20 11 = 1, __
V(1)=XZ(II) ° 44
P(II,L)=0. ° A5
IF (V(l).GT.90.0) GO TO 20 2 ?!
C 047
C **** CALL SECOND SUBROUTINE IN SPLINE INTERPOLATION -SCHEME 0 49
IF (L.EQ.l) CALL SPLNB (MAXZ,Z,RTCON,C,V) O S?
IF (L.GT.l) CALL SPLNB (10, Z, PP (1, L) , C, V) n l->
P(II,L)=AMAX1(0.0,V(2) ) :( ^
20 CONTINUE ° 53
C 0 54
30 CONTINUE ° 55
C DETERMINE TIME OF SOLAR NOON ° 56
C O 57
IZMN=IEND ° 58
XZEM=9999. ° 59
0 60
0-1
-------
DO 40 I=1,IEND 0 gl
IF (XZ(I).GE.XZEM) GO TO 40 0 62
XZEM=XZ(I) 0 63
IZMN-I 0 64
40 CONTINUE 0 65
I=IZMN 0 66
50 TIME-ITIME(I-l) 0 67
XA-XZ(I-l) 0 6Q
DO 60 1=1,60 0 69
SPECIE=TIME 0 7Q
TIME=CLOCK{TIMEf1) 0 71
TSTD=TIME 0 72
IF (TSTD.LT.O.) TSTD=TSTD+2400. n T\
XB=XA 0 74
CALL SOLAR (SLA,SLO,TZ,IY, IM, ID, TSTD,XC,5) 0 75
XA=90.-XC 0 ?6
IF (XA.GT.XB) GO TO 70 0 77
60 CONTINUE 0 7Q
70 DO 80 1=1,IEND 0 79
TMS(I)=60.*FLOAT(I-1) 0 go
80 CONTINUE 0 gl
DO 100 L=1,IP 0 32
DO 90 1=2,IEND 0 83
NMM=IEND+2-I 0 Q4
IF (P(NMM-1,L).GT.O.) GO TO 100 0 85
90 CONTINUE 0 Q6
100 CALL SPLNA (NMM,TMS,P(1,L),2,D,CF(1, L),W) 0 87
RETURN 0 Q8
END
0-2
-------
SUBROUTINE SOLAR {SLA,SLO,TZ,IY,IM,ID,TIME,D,NV)
SAVE
LATITUDE (DEC) SOUTH = MINUS
LONGITUDE (DEC) EAST = MINUS
TIME ZONE
ALSO INCLUDES FRACTION IF LOCAL TIME IS NOT
STANDARD MERIDIAN TIME. E.G. POONA, INDIA 5.5
YEAR
MONTH
AY
LOCAL STANDARD TIME IN HOURS AND MINUTES.
c***
c***
c***
c***
c***
c***
c***
c***
c***
c***
c***
c***
c***
c***
c* **
c***
c***
c***
c* * *
c***
c* * *
SLA.. .
SLO. . .
TZ. ..
IY. .
IM. .
ID. .
TIME. .
D.. R
NV. .
0 ( NV
Y
M
D
E
V
1
2
3
4
5
6
STANDARD TIME **
1 30 PM = 1330
RETURNED VALUE
VALUE TO BE RETURNED, SELECTED AS FOLLOWS
( 7.
DECLINATION (DEC.)
EQUATION OF TIME ADJUSTMENT (HRS )
TRUE SOLAR TIME (HRS.)
HOUR ANGLE (DEC.)
SOLAR ELEVATION (DEC.)
OPTICAL AIRMASS
OTHERWISE, D = 9999.
10
20
DIMENSION MD(ll)
DATA MD/31,29,31,30,31,30, 2*31, 30, 31,307
DATA A,B,C,SIGA/0.15,3.885,1.253,279.93487
RAD=572957,,75913E-4
SDEC=39784.988432E-5
RE=1.
IF (SLO.LT.O.) RE=-1.
KZ=TZ
TC=(TZ-FLOAT(KZ))*RE
TZZ=FLOAT(KZ)*RE
SLB=SLA/RAD
K=ID
TIMH=TIME/100.
I=TIMH
TIMLOC=(TIMH-FLOAT(I))70.6+FLOAT(I)+TC
IMC=IM-1
IF (IMC.LT.l) GO TO 20
DO 10 1=1,IMC .
K=K+MD(I)
LEAP=1
NL=MOD(IY,4)
IF (NL.LT.l) LEAP=2
SMER=TZZ*15.
TK=((SMER-SLO)*4.)/60.
KR=1
IF (K.GE.61.AND.LEAP.LT.2) KR=2
DAD=(TIMLOC+TZZ)724.
DAD=DAD+FLOAT(K-KR)
DF=DAD*360.7365.242
DE=DF/RAD
DESIN=SIN(DE)
DECOS=COS(DS)
DESIN2=SIN(DE*2.)
DECOS2=COS (DE*2.)
SIG=SIG/RAD
DECSIN=SDEC*SIN(SIG)
EFFDEC=ASIN(DECSIN)
IF (NV.NE.l) GO TO 30
D=EFFDEC*RAD
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
P
.00162*P
P
P
P
P
P
P
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
P-l
-------
RETURN p 65
30 EQT=0.12357*DESIN-0.004289*DECOS+0.153809*DESIN2+0.060783*DECOS2 P 66
IF (NV.NE.,2) GO TO 40 p 67
D=EQT p 6Q
RETURN p 6g
40 TST=TK+TIMLOC-EQT p 70
IF (NV.NE.3) GO TO 50 p 71
D=TST . p 72
IF (D.LT.O.) D=D+24. ' p 73
IF (D.GE.24.) D=D-24. p 74
RETURN p ?5
50 HRANGL=ABS(TST-12.)*15. p 76
IF (NV.NE.4) GO TO 60 P 77
D=HRANGL p 7g
RETURN p 79
60 HRANGL=HRANGL/RAD p 8Q
SOLSIN=DECSIN*SIN(SLB)+COS(EFFDEC)*COS(SLB)*COS(HRANGL) P 81
SOLEL=ASIN(SOLSIN>*RAD P 82
IF (NV.NE.5) GO TO 70 P 83
D=SOLEL p 84
RETURN p 85
70 IF (NV.NE.6) GO TO 80 p Q6
IF (SOLEL.LE.O.) GO TO 80 P 87
TK=SOLEL+B p 8fi
E=1./TK**C p 89
D=1./(A*E+SOLSIN) p 90
RETURN p gi
80 D=9999. p 92
RETURN p q!;
END P 94-
P-2
-------
C
C
C
C
C
C
C
C
C
C
C
C
C
10
20
30
40
50
— •" *"•»•— w j. J.1..4-! *jt -uni-x \in,y\, i,U,U,^,WJ
SAVE
DIMENSION X(24), Y(24), D(2), C(72), W(72)
OVER THE INTERVAL X(I) TO X(I+1), THE INTERPOLATING
POLYNOMIAIi
Y=Y(I)+A(I)*Z+B(I)*Z**2+E(I)*Z**3
WHERE Z=(X-X(I))/(X(I+1)-X(I))
Q
Q
Q
Q
Q
Q
n
IS USED. THE COEFFICIENTS A(I),B(I) AND E(I) ARE COMPUTED Q
BY SPLNA AND STORED IN LOCATIONS C (3*1-2) , C (3*1-1) AND O
C(3*I) RESPECTIVELY. n
WHILE WORKING IN THE ITH INTERVAL, THE VARIABLE Q WILL
REPRESENT Q=X(I+1) - X(I), AND Y(I) WILL REPRESENT
Q=X(2)-X(1)
YI=Y(2)-Y(1)
IF (J.EQ.2) GO TO 10
IF THE FIRST DERIVATIVE AT THE END POINTS IS GIVEN
A(l) IS KNOWN, AND THE SECOND EQUATION BECOMES
MERELY B(1)+E(1)=YI - Q*D(1).
C(1)=Q*D(1)
C(2)=1.0
W(2)=YI-C(1)
GO TO 20
IF THE SECOND DERIVATIVE AT THE END POINTS IS GIVEN
B(l) IS KNOWN, THE SECOND EQUATION BECOMES
A(1)+E(1)=YI-0.5*Q*Q*D{1) . DURING THE SOLUTION OF
THE 3N-4 EQUATIONS, Al WILL BE KEPT IN CELL C(2)
INSTEAD OF C(l) TO RETAIN THE TRIDIAGONAL FORM OF THE
COEFFICIENT MATRIX.
C(2)=0.0
W(2)=0.5*Q*Q*D(1)
M=N-2
IF (M.LE.O) GO TO 40
UPPER TRIANGULARIZATION OF THE TRIDIAGONAL SYSTEM OF
EQUATIONS FOR THE COEFFICIENT MATRIX FOLLOWS—
DO 30 1=1, M
AI=Q
0=X (T+?\ -y t r + 1 \
H=AI/Q
C(3*I)=-H/(2.0-C(3*I-1))
W(3*I)=(-YI-W(3*I-1))/(2.0-C{3*I-1))
C(3*I+1)=-H*H/(H-C(3*I))
W(3*I+1)=(YI-W(3*I))/(H-C(3*I))
C(3*I+2)=1.0/(1.0-C(3*I+1) )
W(3*I+2)=(YI-W(3*I+1))/(1.0-C(3*I+1))
E(N-l) IS DETERMINED DIRECTLY FROM THE LAST EQUATION
OBTAINED ABOVE, AND THE FIRST OR SECOND DERIVATIVE
VALUE GIVEN AT THE END POINT.
IF (J.EQ.l) GO TO 50
C(3*N-3)=(Q*Q*D(2)/2.0-W(3*N-4))/(3.0-C(3*N-4))
GO TO 60
C(3*N-3) = (Q*D(2)-YI-W(3*N-4) ) / (2 . 0-C (3 *N-4 ) )
tt
Q
K
Q
Q
Q
Q
Q
Q
Q
Q
o
w
o
»t
Q
Q
Q
Q
Q
Q
Q
Q
Q
Xft
o
w
o
V
Q
Q
— Q
Q
Q
Q
— Q
Q
Q
— Q
Q
Q
Q
Q
Q
Q
Q
--Q
Q
Q
Q
-Q
Q
Q
Q
Q
1
2
3
4
5
6
7
f
g
w
9
10
1 1
X J.
12
13
14
15
16
17
18
19
20
2 1
&• J.
22
23
24
25
26
27
28
29
30
31
32
33
•»J *J
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
A (\
4 9
C A
J U
c -s
51
53
C A
54
55
56
57
58
59
60
61
62
63
64
Q-l
-------
60 M=3*N-6 Q 65
IF (M.LE.O) GO TO 80 Q 66
C Q g 7
C BACK SOLUTION FOR ALL COEFFICENTS EXCEPT Q 68
C A(l) AND B(l) FOLLOWS— Q 69
C 7
DO 70 11=1,M 0 71
I=M-II+3 Q 72
70 C(I)=W(I)-C{I)*C(I+1) Q 73
80 IF (J.EQ.l) GO TO 90 Q 74
c Q 75
C IF THE SECOND DERIVATIVE IS GIVEN AT THE END POINTS, Q 76
C A(l) CAN NOW BE COMPUTED FROM THE KNOWN VALUES OF Q 77
C BCD AND E(l). THEN A(l) AND B{1) ARE PUT INTO THEIR Q 78
C PROPER PLACES IN THE C ARRAY. Q 79
C Q Q Q
C(1)=Y(2)-Y(1)-W(2)-C(3) 0 ai
C(2)=W(2) 0 82
RETURN Q Q3
90 C(2)=W(2)-C{3) 0 84
RETURN Q 85
END Q 86-
Q-2
-------
c
c
c
c
c
c
c
c
c
SUBROUTINE SPLNB (N,X,Y,C,V)
SAVE
DIMENSION X(24), Y(24), C(72), V(5)
V(5)=2.0
LIM=N-1
DETERMINE IN WHICH INTERVAL THE INDEPENDENT
VARIABLE, V(l), LIES.
DO 10 1=2, LIM
IF (V(l) .LT.X(I)) GO TO 20
10 CONTINUE
I=N
IF (V(l) .GT.X(N) ) V(5)=3.0
GO TO 30
20 IF (V(l) .LT.X(l)) V{5)=1.0
Q IS THE SIZE OF THE INTERVAL CONTAINING V(l).
Z IS A LINEAR TRANSFORMATION OF THE INTERVAL
ONTO (0,1) AND IS THE VARIABLE FOR WHICH
THE COEFFICIENTS WERE COMPUTED BY SPLNA.
30 Q=X(I)-X(I-1)
V (2) =((Z*C (3*1-3 )+C (3*1-4 ))*Z+C (3*1-5) )*Z+Y(I-1)
V(3)=((3.*Z*C(3*I-3)+2.0*C(3*I-4))*Z+C(3*I-5))/Q
V(4)=(6.*Z*C(3*I-3)+2.0*C(3*I-4))/(Q*Q)
RETURN
END
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
R
2
0
J
4
5
6
7
8
9
10
11
12
13
1 A
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30-
R-l
-------
FUNCTION CLOCK (T1,1INC) SI
SAVE c o
r
S3
C **** ADD A TIME IN MINUTES TO A 2400 HOUR TIME AND RETURN A 24DOS 4
C **** HOUR TIME c =
C
S 6
T2-IINC s 7
I100=INT(T1/100.) s g
T3=Tl-100.0*FLOAT(I100)-(-T2 s q
I100=I100+INT(T3/(50.) s 1Q
CLOCK=FLOAT(1100)*100.0+T3-60.0*FLOAT(INT(T3/60.0)) s 11
RETURN o 10
EN° s \l-
S-l
-------
SUBROUTINE SUNTIM
SAVE
•*
: FIND SUNRISE AND SUNSET VALUES
•H
COMMON /SUNLIT/ Z(10), RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM,ID
1 ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),XZ
2' , KJ{24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,MAXJ
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6),
1 AMXX(26),DL,TTMAX,SSRISE,SRMIN,DELH, TOIL,NMXX,
2 HEIGHT,SSET,SRISE
INTEGER PSPEC
*
: FIND SUNRISE
T=0.
10 CALL SOLAR(SLA,SLO,TZ,IY,IM,ID,T,D,5)
IF (D.GE.0.000001) GO TO 20
T=CLOCK(Tf 60)
GO TO 10
: FIND HALF HOUR VALUE
20 T=T-150.
CALL SOLAR (SLA, SLO,, TZ, IY, IM, ID, T, D, 5)
IF {D.GE.0.000001) GO TO 40
30 T=CLOCK(T,1)
CALL SOLAR(SLA,SLO,TZ,IY,IM,ID,T,D,5)
IF (D.GE.0.000001) GO TO 60
GO TO 30
40 T=T-30.
50 T=CLOCK(T,1)
CALL SOLAR (SLA, SLO, TZ, IY, IM, ID, T, D, 5)
IF (D.LT.0.000001) GO TO 60
GO TO 50
60 SRISE=T
FIND SUNSET
T=1200.
70 CALL SOLAR(SLA,SLO,TZ,IY,IM,ID,T,D,5)
IF (D.LT.0.000001) GO TO 80
T=CLOCK(T,60)
GO TO 70
FIND HALF HOUR VALUE
80 T=T-150.
CALL SOLAR(SLA,SLO,TZ,IY,IM,ID,T,D,5)
IF (D.LT.0.000001) GO TO 100
90 T=CLOCK(T,1)
CALL SOLAR (SLA, SLO, TZ, IY, IM, ID, T, D, 5)
IF (D.LT.0.000001) GO TO 120
GO TO 90
100 T=T-30.
110 T=CLOCK(T,1)
CALL SOLAR(SLA,SLO,TZ,IY,IM, ID,T,D,5)
IF (D.GE.O.000001) GO TO 120
GO TO 110
T
T
T
T
T
T
(24)T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
T
1
2
3
4
5
6
7
8
9
9A
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
T-l
-------
C T 64
120 SSET=T T 65
C T 66
RETURN T 67
END T 6Q.
T-2
-------
SUBROUTINE EKCALC
SAVE
(X)
THIS SUBROUTINE PERFORMS VOC CONTROL REQUIREMENTS AS OUTLINED
™,IIP 1981 EPA GUIDELINES ON THE USE OF CITY-SPECIFIC EKMA THIS
ROUTINE ALSO INCLUDES PROCEDURES DESCRIBED IN APPENDIX B OF THE
1981 GUIDELINES.
THIS ROUTINE WAS MODIFIED OCT 1986 BY HH/SAI TO:
ALLOW FOR TWO OCCURANCES OF OZONE ON A NMOC/NOX LINE
TO SKIP BASE YEAR CALCULATION IF LOCATION IS KNOWN
MODIFIED JUNE 1987 HH/SAI TO:
ALLOW FOR CO EMISSION CREDITS
COMMON /CALC/ NR,KR(200,12),A(200),S(200),R(200),ITYPE(200),IA(60)U
rnMMOM /™™T /JA(800)''DILUT< TEMP, ERR, START, STOPP, TPRNT, TSTEP, ZENI U
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTO,TSRT,DTIM,Zl,Z2,DCON,EHC EXN
1 FLST,TLST '
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2)
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY,IM ID
ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),XZ(24)U
PHMMOM
COMMON
,KKK(24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,MAXJ
CF(72,20),P(24,20),IPH(20),IP,RFCT(20),PP(10,20)
- IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10),
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /ZENITH/ IPZ,ZDEF (10,20),IPHZ(20),IZENP
COMMON /EMIS/ NEM,ISP,ESTRT(5),ESTOP, ESLP, IEMLS(5),EOSLP(5)
rnMMAM /MTV/ EMO(26'5>'ECI<5),EM(26),EC(125),ECO(125,5)
COMMON /MIX/ NMIX,AMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6)
1 AMXX(26),DL, TTMAX, SSRISE,SRMIN,DELH,TOIL,NMXX,
2 HEIGHT,SSET,SRISE
COMMON /TEMPER/ TEMEND,NTEMP,QM(30)
COMMON /FRPLOT/ SAVCON(80,5),SAVTIM(80),NTSV,INOW
COMMON /INOUT/ IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
ITTL(36)
HC,XN,NL,OZP(20),OZN(11,11,5),MR,LS,HCS,XNS
SC(200,12),ISC(200,3)
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02, IINO, 1103
IIH20,JPLUS
COMMON /TITL/
COMMON
COMMON /NEED I/
COMMON /HOUR/ OZM(5),NGO,TTM,TMY(5)
COMMON /PLTVEC/ HCT(20),OT(20),NT,OHC,HCG,PLTGRD,OXN,XNG,HC1,XN1
fTiT^fJr\T-xi'in ,«»»•«.«»-.._. * * F
COMMON /ALOFT/
COMMON /WLB1/
rn ™ ,
COMMON /CRED/
rnMMOM
COMMON
TICZ,DIGZ,CHRZ,IPLDEV
IALFT,CALFT(10),LOCALF(10)
FCTR,DIST,CHRSIZ,NNCHR,OZBL
FBK{20),FBKAL(5),HCBK,XNBK,OZBK,H20BK
ICR,ISPCR,SPCR69(3),SURFCR(3),ALOFCR(3)
REDCR(3),FSRFCR(3),FALFCR{3),COSFBK,COAFBK
NBEM,IBSP,WTMOL(5),ACB4(5),SURFBI (5),
ALOFBI(5),REDBI(5),FSRFBI(5),FALFBI(5),BEMO(26,5)
BECO(126,5),CBTOT(5),IBLS(5),BESTOP,BFRAC(20,5)
COMMON /ALFCHR/ ISPAL(IO)
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
U
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
))U
[ U
u
u
u
u
u
u
:)U
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
35A
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
53A
53B
53C
53D
53E
53F
53G
53H
531
53J
U-l
-------
COMMON /CALCHR/ SPECIS(61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*4 ISPAL, ISPDP, ISPNCR, IBEMSP
CHARACTER*4 SPECIS, HCSPEC, PLSP, IISOP, EMSP, REACT
CHARACTERM IBLANK,MBLANK, IIHC,IINX, IICO,IIN02,IINO, 1103,
1 IIH20,IBZA,JPLUS
DIMENSION X(7),OZOUT(11),OZV(10),HCTMP(10),ANXTMP(10),OZSORT(10),
HCSORT(IO),ANSORT(10),YP(20),TM(20),SCRSV(3),ALCRSV(3),
SPCRSV(3),SBIOSV(5),ABIOSV(5),EM1(26)
1
2
FOZS =
FOZA =
FOCS =
FOCA =
FXNS =
FXNA =
CFHC =
HI
S!
OZIN
OZAL
HCIN
HCAL
XNIN
XNAL
0.0
CFNOX =0.0
NPTO=0
INFO=-1
DOZ =0.12
AOZ=0.12
HCTNOX=1.
NTRYS = 8
ACCU = 0.0005
RNMOC=0.60
BNMOC = HCBK
IF (ABS(X(1))
IF (ABS(X(2))
IF (X(4) .GT.
.NE. 0.0) DOZ = ABS(X(1))
.NE. 0.0) HCTNOX = ABS(X(2))
0.0) READ (IN,400) FOZS,FOZA,FOCS,FOCAfFXNS,FXNA
READ (IN,400) HCMEAS,ANMEAS,ALREHC,ALRENX,HCLV
REDNOX = 1.0 + X(3)*.01
DO SOME PRELIMINARY CALCULATIONS
OZINSV=OZIN
OZALSV=OZAL
HCINSV=HCIN
HCALSV=HCAL
XNINSV = XNIN
XNALSV=XNAL
IF (ICR.LE.O) GO TO 15
DO 10 J=1,ICR
SCRSV(J)=SURFCR(J)
ALCRSV(J)=ALOFCR(J)
SPCRSV(J)=SPCR69(J)
10 CONTINUE
15 IF (IBSP.LE.O) GO TO 20
DO 16 J=l,IBSP
SBIOSV(J)=SURFBI(J)
ABIOSV(J)=ALOFBI(J)
16 CONTINUE
20 REDNX1=X(3)
ESTIMATE FUTURE NMOC IF NOT GIVEN
RNMOC1=FOCA
IF (FOCA.GE.O.) GO TO 30
IF (FOCA.GT. (-99.) ) RNMOC=ABS(FOCA)*0.01
0
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
53K
53L
53M
53N
530
53P
53Q
53R
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
96A
96B
96C
96D
96E
97
98
99
100
101
102
103
104
U-2
-------
RNMOC1 = (HCALSV - BNMOC)*RNMOC + BNMOC
ESTIMATE FUTURE NMOC IN THE SURFACE LAYER
30 RNMOC2 = (HCINSV - BNMOC)*RNMOC + BNMOC
IF (FOCS.GE.O.) RNMOC2=FOCS
IF (FOCS.LT.(-0.00001)) CFHC=ABS(FOCS)
IF (FXNS.LT.(-0.00001)) CFNOX=ABS(FXNS)
CHCNOX = HCTNOXM1.-CFHO/U.-CFNOX)
ROZ1=FOZA
IF (FOZA.GE.O.) GO TO 50
USE THE OZONE TRANSPORT CURVES TO ESTIMATE FUTURE OZONE IF
FUTURE OZONE IS NEGATIVE (SEE 1981 CITY-SPECIFIC GUIDELINES P. 54)
ROZ1=OZALSV
IF (OZALSV .LE. 0.04) GO TO 50
IF INPUTED FUTURE OZONE VALUE IS LESS -100 THEN USE
DASH LINE OF OZONE CURVE
IF (FOZA.LT.(-99.)) GO TO 40
ROZ1 = 0.7*OZALSV + 0.012
IF (OZALSV .GT. 0..1543) ROZ1 = 0 12
GO TO 50
40 ROZ1 = 0.9*OZALSV + 0.004
IF (OZALSV .GT. 0.129) ROZ1 = 0.12
REPEAT FUTURE OZONE ESTIMATE FOR SURFACE LAYER
50 ROZ2=FOZS
IF (FOZS.GE.O.) GO TO 70
ROZ2=OZINSV
IF (OZINSV .LE. 0.04) GO TO 70
IF (FOZS.LT. (-99.)) GO TO 60
ROZ2 = 0.7*OZINSV -I- 0.012
IF (OZINSV .GT. 0.1543) ROZ2 = 0 12
GO TO 70
60 ROZ2 = 0.9*OZINSV + 0.004
IF {OZINSV .GT. 0.129) ROZ2 =0.12
70 HC1 = -99.0
HC2 = 1.0
OXN2 = HC2/HCTNOX
IFL=0
WRITE (IOUT,410) DOZ,HCTNOX,REDNX1,ROZ1,RNMOC1,FXNA
IF (ICR.LE.O) GO TO 85
DO 80 J=1,ICR
WRITE (IOUT,450) ISPNCR(J),ISPNCR(J),REDCR(J),
1 ISPNCR (J),FALFCR(J'i
80 CONTINUE
85 IF (IBSP.LE.O) GO TO 90
DO 86 J=l,IBSP
WRITE (IOUT,451) IBEMSP{J),IBEMSP(J),REDBI(J),IBEMSP(J)
1FSRFBI(J),IBEMSP(J),FALFBI(J)
86 CONTINUE
90 CONTINUE
ITE {IOUT'420> CFHC,CFNOX,
ROZ2,RNMOC2,FXNS,PLSP(1)
PLSP(l) T'°'> WRITE (I°UT'/340) ROZ2'RNM°C2,FXNS,ALREHC,ALRENX,
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
156A
156B
156C
156D
156E
157
158
159
160
161
162
163
U-3
-------
IF BASE YEAR PRECURSOR TRANSPORT IS LESS THAN BACKGROUND
THEN SKIP APPENDIX B PROCEDURES
IF (X(2) .LT.O.) GO TO 270
IF (HCIN .LE. HCBK) GO TO 150
IF (CFHC.LE.O. .AND.CFNOX.LE.O.) GO TO 150
DO APPENDIX B (STEP 3)
HCIN =0.0
DO 110 1=1, NTRYS
CALL SIM (HC2,OXN2,ZN2,10)
OZV(I)=ZN2
HCTMP (I)=HC2
ANXTMP ( I ) =HC2
DIFF = ABS(ZN2-DOZ)/DOZ
IF (DIFF .LE. ACCU) GO TO 120
IF (HC1 .NE. (-99.0)) GO TO 100
HC1=HC2
ZN1=ZN2
HC2=HC1*DOZ/ZN2
OXN2=HC2/HCTNOX
GO TO 110
100 B=(DOZ-ZN1) * (HC2-HC1)/ (ZN2-ZN1 ) -l-HCl •
CHECK FOR REVERSING TREND. FIX SO WE DO NOT LOOP
IF (ZN2.GT.ZN1 .AND. HC2.LT.HC1 .AND. ZN2.GT.DOZ)
1 B = DOZ*HC2/ZN2
IF (B.LT.O.) B=HC2/2.0
HC1=HC2
ZN1=ZN2
HC2=B
OXN2=HC2/HCTNOX
110 CONTINUE
IFL=1
GO TO 180
DO STEPS 4, 5, AND 6 (APPENDIX B)
120 HCIN = HC2*CFHC
XNIN = OXN2*CFNOX
HCTNOX = CHCNOX
HCl=-99.
RNMOC2 = (HCIN - BNMOC) *RNMOC + BNMOC
HC2 = OXN2*HCTNOX
IF (CFHC.LE.O. .AND.CFNOX.LE.O. ) GO TO 150
DO 140 J=1,ISP
IF (EMSP(J) .NE.IIHC.AND.EMSP(J) .NE.IINX) GO TO 140
IF (EMSP(J) .EQ.IIKC) CFX=CFHC
IF (EMSP(J) .EQ.IINX) CFX=CFNOX
IEM = ESTOP/ 60.
IF (NEM.GT.O) GO TO 131
DO 130 1=1, IEM
EMI ( I ) =EMO ( I , J) / ( 1 . -CFX)
130 CONTINUE
CALL EMISS(IEM,EM1,ECO(1, J) )
GO TO 140
131 IF (J.GT.l) GO TO 140
DO 132 1=1, NEM
EM1(I)=EM(I)/(1.-CFX)
132 CONTINUE
CALL EMISS (NEM, EMI, EC)
140 CONTINUE
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
206A
207
208
209
210
211
212
213
213A
213B
214
215
216
217
217A
217B
217C
217D
217E
217F
218
U-4
-------
c
C NOW DO BASE CASE CALCULATION JJ ?i?
C U 220
150 DO 170 1=1, NTRYS U 221
CALL SIM
-------
THERE IS A MAXIMUM ALONG NMOC/NOX
FIND THE LOCATIONS
DO 210 J=1,LHX
HCTMP(J)=HCSORT(J)
OZV{J)=OZSORT(J)
210 CONTINUE
HCTMP (MM )==HMX
OZV(MM)=OZHX
SX=-SIG*3.0
IF (MM.GT.2) SX=-SIG*60./(FLOAT(MM-2)**2)
220 CALL CURV1{MM,OZV,HCTMP,SP1,SP2,YP,TM,SX)
IT=1
HCML1=CURV2(DOZ,MM,OZV,HCTMP,YP,SX,IT)
IF {IT.GT.O) GO TO 230
SX=SX*10.
SX=AMAX1(--50.,SX)
GO TO 220
230 CONTINUE
NOW DO UPPER PORTION
MDIF=NTRYS-LHX
DO 240 J=1,MDIF
MJ=NTRYS-J
OZV(J)=OZSORT(MJ)
HCTMP{J)=HCSORT(MJ)
240 CONTINUE
OZV(MDIF+1)=OZHX
HCTMP(MDIF-t-l)=HMX
MDIF=MDIF+1
SX=-SIG*3.0
IF (MDIF.GT.2) SX=-SIG*60./(FLOAT(MDIF-2)**2)
250 CALL CURV1(MDIF,OZV,HCTMP,SP1,SP2,YP,TMfSX)
IT=1
HCML2=CURV2(DOZ,MDIF,OZVfHCTMP,YP,SX, IT)
IF (IT.GT.O) GO TO 260
SX=SX*10.
SX=AMAX1(--50.,SX)
GO TO 250
260 CONTINUE
SEE WHICH VALUE IS CLOSEST TO MEASURED NMOC AND NOX
XNM1=HCML1/HCTNOX
XNM2=HCML2/HCTNOX
HCD1=SQRT((HCML1-HCMEAS)**2 + (XNM1-ANMEAS)**2)
HCD2=SQRT{(HCML2-HCMEAS)**2 + (XNM2-ANMEAS)**2)
WRITE (IOUT,540) HCML1,XNM1,HCML2,XNM2,HCMEAS,ANMEAS,PLSP(1)
HC2=HCML1
OXN2=XNM1
IF (HCD2.LT.HCD1) HC2=HCML2
(HCD2.LT.HCD1) OXN2=XNM2
(HCMLl.LT.HCSORT(l).OR.HCML1.GT.HCSORT(NTRYS)) HC2=HCML2
(HCMLl.LT.HCSORT(l).OR.HCML1.GT.HCSORT(NTRYS)) OXN2=XNM2
(HCML2.LT.HCSORT(1).OR.HCML2.GT.HCSORT(NTRYS)) HC2=HCML1
IF (HCML2.LT.HCSORT(1).OR.HCML2.GT.HCSORT(NTRYS)) OXN2=XNM1
IF (HC2.LT.HCSORTU) .OR. HC2 . GT .HCSORT (NTRYS)') WRITE(IOUT,570)
(HC2.LT.HCSORT(1).OR.HC2.GT.HCSORT(NTRYS)) GO TO 330
(IFL.EQ.l) GO TO 120
IF
IF
IF
IF
IF
IF
IFL=3
GO TO
150
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
U-6
-------
FOUND IT. NOW DO FUTURE YEAR CALCULATION
270 IF (X(2).LT.O.) OXN2-ALRENX
IF (X(2).LT.O.) HC2-ALREHC
OXN1 « OXN2*REDNOX
HCORG = HC2
IF (X{6).LT.(-0.000001)) GO TO 330
HCAL=RNMOC1
HCIN=RNMOC2
OZAL=ROZ1
OZIN=ROZ2
IF (FOCS.GT. (-0.00001))
IF (FXNS.GE. (-0.00001))
IF (FXNA.GE.(-0.00001))
HCIN=FOCS
XNIN=FXNS
XNAL=FXNA
ALLOW FOR OTHER EMISSIONS CREDITS (ONLY FOR CO CURRENTLY)
IF (ICR.LE.O) GO TO 285
DO 280 J=1,ICR
SPCR69{J)=SPCR69(J)*(1.+REDCR(J)*0.01)
SURFCR(J)=FSRFCR(J)
ALOFCR(J)=FALFCR(J)
280 CONTINUE
285 IF (IBSP.LE.O) GO TO 290
DO 287 J=l;IBSP
SURFBI(J)=FSRFBI(J)
ALOFBI(J)=FALFBI(J)
DO 286 L=1,NBEM
EMI(L)=BEMO(L, J) * {1.+REDBI(J)*0.01)
286 CONTINUE
CALL EMISS (NBEM,EM1,BECO(1,J))
287 CONTINUE
290 CONTINUE
TAKE AN INITIAL GUESS AT VOC REDUCTION (50 PERCENT)
HC1=0.5*HC2
HC2 = 0.0
ZN2 = 0.0
OXN2 = OXN1
HC3 = 0.5
DO 310 1=1, NTRYS
11=1
CALL SIM (HC1,OXN1,ZN1,10)
DIFF = ABS(ZN1-AOZ)/AOZ
IF (DIFF .LE. ACCU) GO TO 320
IF (ZN1.GT.AOZ.AND.HC3.LE.O.) II=NTRYS+1
IF (ZN1.GT.AOZ.AND.HC3.LE.O.) GO TO 320
DELTA =1.0
IF (ZN1 .NE. ZN2) DELTA = (HC1 - HC2)/(ZN1 - ZN2)
IF ((ABS(AOZ-ZNl) .GT. ABS(AOZ-ZN2)) .AND I NE 1)
HC3 = HC1 + (AOZ - ZN1)*DELTA
ZN2 = ZN1
HC2 = HC1
HC1 = HC3
IF (HC1 .LT. 0.0) HC1 = 0.0
GO TO 310
HC1 = HC2 + (AOZ - ZN2)*DELTA
HC3 = HC1
IF (HC1 .LT. 0.0) HC1 = 0.0
300
310 CONTINUE
320 IF (II.GE.NTRYS) WRITE (IOUT,460) AOZ,I
U 347
U 348
U 349
U 350
U 351
U 352
U 353
U 354
U 355
U 356
U 357
U 358
U 359
U 360
U 361
U 362
U 363
U 364
U 365
U 366
U 367
U 368
U 369
U 370
U 370A
U 370B
U 370C
U 370D
U 370E
U 370F
U 370G
U 370H
U 3701
U 371
U 372
U 373
U 374
U 375
U 376
U 377
U 378
U 379
U 380
U 380A
U 381
U 382
U 383
U 383A
U 383B
U 384
U 385
GO TO 300 U 386
U 387
U 388
U 389
U 390
U 391
U 392
U 393
U 393A
U 394
U 395
U 396
U 397
U-7
-------
IF (II.GE.NTRYS) GO TO 330
REDUC = (HCORG - HC1)*100.0/HCORG
IF (REDUC.LE.90.) WRITE (IOUT,470) REDUC
IF (REDUC.GT.90.) WRITE (IOUT,560) REDUC
330 IF (ABS(X(6)).EQ.O.) GO TO 340
HC1=HCORG*(l.+HCLV*0.01)
WRITE (IOUT,480) HCLV,PLSP(1)
CALL SIM(HC1,OXN1,ZN1,10)
DO OZIPM-2 EKMA OPTION TO GENERATE CHANGE IN OZONE
340 IF (X(S).LE.O.) GO TO 360
THE FOLLOWING ALGORITHM WAS DEVELOPED BY EPA (GIPSON, 1984)
WRITE(IOUT,490)
WRITE(IOUT,500)
DELHC=10.0
DO 350 K=lrll
DELHC=DELHC-10.
HC2=HCORG*(l.O+DELHC/100.)
CALL SIM(HC2,OXN1,ZN,5)
DEL03=((ZN-DOZ)/DOZ)*100.
WRITE(IOUT,510) HC2,OXN1, ZN,DELHC,X(3),DEL03
OZOUT(K)=ZN
350 CONTINUE
IF (X(5).EQ.2) WRITE(IOZC,520) OZOUT
RESET VALUES FOR NEXT OPTION
360 CONTINUE
RESET EMISSIONS IF APPENDIX B WAS USED
IF (HCINSV.LE.HCBK.AND.XNIN.LE.XNBK) GO TO 380
IF (CFHC.LE.O..AND.CFNOX.LE.O.) GO TO 380
DO 370 J=1,ISP
IF (NEM.LT.O) CALL EMISS(IEM,EMO(1,J),ECO(1, J))
IF (NEM.GT.O) CALL EMISS(NEM,EM,EC)
370 CONTINUE
380 CONTINUE
NPTO=0
INFO=0
OZIN=OZINSV
OZAL=OZALSV
HCIN=HCINSV
HCAL=HCALSV
XNIN=XNINSV
XNAL=XNALSV
IF (ICR.LE.O) GO TO 395
DO 390 J=1,ICR
SPCR69(J)=SPCRSV(J)
SURFCR(J)=SCRSV(J)
ALOFCR(J)=ALCRSV(J)
390 CONTINUE
395 IF (IBSP.LE.O) RETURN
DO 396 J=l,IBSP
SURFBI(J)=SBIOSV(J)
ALOFBI(J)=ABIOSV(J)
CALL EMISS (NBEM,BEMO(1,J),BECO(1, J) }
396 CONTINUE
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
438A
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
454A
454B
454C
454D
454E
454F
U-8
-------
RETURN
C FORMAT STATEMENTS
400 FORMAT (7F10.5) U
410 FORMAT (1H1 // 40X,43HEKMA CALCULATIONS ARE PERFORMED TO ESTIMATU
' 38HSITE-SPECIFIC VOC CONTROL REQUIREMENTS // 1HO U
F10 3 4H PPM / i wn n
, F10 3 / ?HO 39X U
,F10 3 8H PERCENT/' 1HO U
' ,lll "X III / H^' U
,F10.3,5H PPMC / 1HO U
,F10 3 5H PPM )
,*iu.j,:>H PPM )
36HBASE YEAR OZONE
339X ,36HBASE YEAR NMOC/NOX
4 36HANTICIPATED CHANGE IN NOX
539X, 36HFUTURE OZONE TRANSPORTED ALOFT
639X, 36HFUTURE NMOC TRANSPORTED ALOFT
739X, 36HFUTURE NOX TRANSPORTED ALOFT
420 FORMAT (1HO,39X,
1 36HMEDIAN CONTRIBUTION FACTOR FOR NMOC ,F10.3 / 1HO,39X
2 36HMEDIAN CONTRIBUTION FACTOR FOR NOX
3 36HADJUSTED NMOC/NOX
430 FORMAT (1HO,39X,
1 36HFUTURE OZONE IN THE SURFACE LAYER
239X, 36HFUTURE NMOC IN THE SURFACE LAYER
339X, 36HFUTURE NOX IN THE SURFACE LAYER ,.,
4 ////1H1 ///,40X,36HTHE FOLLOWING SIMULATIONS WERE DONE /1HO
440 ™^ '
,F10.3 / 1HO 39X
,F10.3,4H PPM / 1HO U
, F10 . 3, 5H PPMC / 1HO U
,F10.3,5H PPM
1 36HFUTURE OZONE IN THE SURFACE LAYER ,F10.3,4H PPM / 1HO U
239X, 36HFUTURE NMOC IN THE SURFACE LAYER , F10 . 3, 5H PPMC / 1HO U
339X, 36HFUTURE NOX IN THE SURFACE LAYER F10.3 5H PPM / IRQ U
439X, 55HBASE YEAR NMOC AND NOX LOCATIONS ARE ALREADY DETERMINED/ '
j 1HU ,
639X, 36HBASE YEAR INITIAL NMOC LOCATION ,F10.3,5H PPMC / 1HO U
739X, 36HBASE YEAR NOX LOCATION F10 3 5H PPM
8 ////1H1 ///40X,36HTHE FOLLOWING SIMULATIONS WERE DONE./1HO '
9 15X,4HNMOC,17X,3HNOXf15X,5HRATIOf17X/A4,16Xf4HTIME) '
450 FORMAT ( 1HO, 39X, 37HEMISSION CREDITS WILL BE ALLOWED FOR A4/1HO
^ov^^nf TICIPATED CHANGE IN 'A4/10X,F10.3f8H PERCENT /1HO
239Xf7HFUTURE ,A4,25H TRANSPORTED ALOFT ,F10.3,4H PPM
451 FORMAT (1HO, 39X, 42HFUTURE BIOGENIC EMISSIONS WILL BE SET FOR
CHANGE IN 'A4f10X,F10.3,8H PERCENT
TRANSPORTED IN THE SURFACE LAYER,F10.3
,7HFUTURE ,A4,25H TRANSPORTED ALOFT
4F10.3,4H PPM ) '
460 FORMAT (1HO // 40X,,15HCOULD NOT FIND ,F10.4,10H OZONE IN
1 13, 6H TRYS //40X,34HCHECK INPUT CONDITIONS OR GENERATE
2 /40X,20HAN ISOPLETH DIAGRAM. )
470 FORMAT (1HO // 40X,27HVOC CONTROL REQUIREMENT IS ,F5.1,8H PERCENT) U
1"™ FOLLOWING SIMULATION WAS DONE WITH A ' U
PERCENT CHANGE IN NMOC. /1HO, n
/ *iiw f U
U
PPM DOES NOTU
OZONU
, . , ,
,'EKMA PREDICTED CHANGES IN OZONE')
490 FORMAT
500 FORMAT
1'%-CHG NOX',3X,'%-CHG 03'/)
510 FORMAT(38XfF6.3,3XrF5.3,3X,F5.4,4X,F6.1,5XrF6.1,
16X,F6.1)
520 FORMAT(11F5.3)
530 FORMAT (1HO,39X, 23HTHE BASE YEAR OZONE OF ,F10.3,
or, T0 _, „ „ GIVEN INPUTS. /40X, 32HTHE MAXIMUN
2E IS ,F10.3,5H PPM.//)
BASE YEAR OZONE OCCURS AT
. RATIO:/1HO,
3
455
456
457
458
459
46?
462
464
>,u
),u
u
u
u
u
u
u
1,0
>,u
u
u
u
u
,u
,u
,u
u
u
/u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
u
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
492A
492B
492C
492D
492E
493
494
495
496
497
98
500
5"
505
507
508
.f.,,
,45HTHE LOCATION CLOSEST TO THE MEASURED NMOC OF
512
513
U-9
-------
4 F10.3, 5H PPMC /40X,11HAND NOX OF ,F10.3,18H PPM WILL BE USED. U 514
5 / 40X,50HTHE FOLLOWING SIMULATIONS WERE DONE AT THIS POINT./ U 515
61HO,14Xf4HNMOCf17X,3HNOXr15Xf5HRATIOf17XfA4,16X,4HTIME) U 516
550 FORMAT (1HO,39X,21HCANNOT FIND OZONE OF ,F5.2,17H AFTER SECOND SETU 517
1/40X,56HOF ITERATIONS. CHECK INPUTS OR GENERATE AN ISOPLETH DIA, U 518
25HGRAM. ) U 519
560 FORMAT (1HO,39Xf33HNOTE THE CALCULATED REDUCTION OF ,F6.2,8H PERCEU 520
1NT/40X,54HMAYBE UNREALISTIC WITH THE GIVEN INPUTS. U 521
2/40X,35HAN ISOPLETH DIAGRAM IS RECOMMENDED. ) U 522
570 FORMAT (1HO,39X,44HBOTH CALCULATED NMOC AND NOX LOCATIONS ARE / U 523
140X,57HOUTSIDE RANGE OF INTERPOLATION. CHECK INPUTS OR GENERATE U 524
2/40X,20HAN ISOPLETH DIAGRAM. ) U 525
C U 526
END U 527-
U-10
-------
SUBROUTINE SIM (HCHH,XNHH, ZN, INX)
THIS ROUTINE CONTROLS THE SIMULATION OF AN INDIVIDUAL CALCULATION
SAVE
COMMON /CALC/ NR, KR<200, 12) , A{200) , S (200) , R (200) , ITYPE (200) , IA(60) V
COMMON /TITL/
COMMON /HOUR/
COMMON /CNTRL/
L
COMMON /EMIS/
L
COMMON /HEAT/
COMMON /NEEDI/
,ERR,START,STOPP,TPRNT,TSTEP,ZENI
OZM(5),NGO/TTM,TM(5)
SIG,SIGMA,INFO,NPTO,TSRT,DTIM,Zl,Z2,DCON,EHC,EXN,
FLST,TLST
NEM,IS1,ESTRT(5),ESTOP,ESLP,IEMLS(5),EOSLP(5)
EMO(26,5),ECI(5),EM(26),EC(125),ECO(125,5)
SC(200,12),ISC (200,3)
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,1103,
IIH20,JPLUS
COMMON /FRPLOT/ SAVCON(80,5),SAVTIM(SO),NT,INOW
COMMON /INOUT/
COMMON /SPEC/
INU,IOUT,ITAPE,IALN,IALL,INI,IOZC
NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN
2 XNAL,NOZ,FENX{2),CI(61) , NI,KOZ(5)
COMMON /SUNLIT/ Z(10),RTCON(10),LAM1,INC,SLA,SLO,TZ,IY IM ID
1 • ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),'
COMMON /HJH/ HCSAv! XN^ ' ' **™' J*™' *™' "^ M™' MAXL' ^
COMMON /PHOTON/ CF (72,20),P{24,20),IPH(20),IP,RFCT(20),PP(10,20)
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10),
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /MIX/ NMIX,AMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6),
COMMON /BK1/
COMMON /CRED/
L
COMMON /BIOG/
COMMON /WATER /
AMXX(26),DL,TTMAX,SSRISE,SRMIN,DELH,TOIL,NMXX,
HEIGHT,SSET,SRISE
FBK(20),FBKAL(5),HCBK,XNBK,OZBK, H20BK
ICR,ISPCR,SPCR69(3),SURFCR(3),ALOFCR(3),
REDCR(3),FSRFCR(3),FALFCR(3),COSFBK,COAFBK
NBEM,IBSP,WTMOL{5),ACB4(5),SURFBI(5),ALOFBI(5),
REDBI(5),FSRFBI(5),FALFBI(5),BEMO(26,5),
BECO(126,5),CBTOT(5),IBLS(5),BESTOP,BFRAC(20,5)
WATEND,NWATER,PAMB,QW(30),QR(30),PMILLI,ILH20
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /CALCHR/ SPECIS(61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*2 ITTL
CHARACTERM ISPDP, ISPNCR, IBEMSP
CHARACTERM SPECIS, HCSPEC, PLSP, REACT, IISOP, EMSP
CHARACTERM IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103
L HH20, IBZA,JPLUS,INST
DIMENSION RT(200), RX(20), C(61), C03(5), INST(3,5),YY(61,6)
DATA INST/' (INS','TANT',')
1'(INS','TANT',') ' ,'(INS1
ISP=IS1+ICR
TCI=FLOAT(JSTRT)
HC=HCHH
XN=XNHH
START=0.
(INS','TANT',' )
TANT'
(INS','TANT' ')
V
V
V
V
V
50)V
n v
V
V
!, V
V
V
V
V
V
V
V
V
V
V
i, v
V
V
V
.XJV
V
, v
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
/v
V
V
V
V
V
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
32A
33
34
35
35A
35B
35C
35D
35E
35F
35G
35H
351
35J
35K
35L
35M
35N
350
35P
35Q
35R
35S
36
37
38
39
39A
40
41
42
43
V-l
-------
T=START
TDIL=0.
TTRS=CLKMIN (TCI)
TTR1=CLKMIN (SRISE)
TTR2=CLKMIN (SSET)
TR1=TTR1-TTRS
TR2=TTR2-TTRS
IF (TR2.LE.O.) TR2=2000.
IF (TRl.GE.,0. .OR. ( (JSTOP-JSTRT) .GT.100) ) GO TO 10
TR2=1440.+TR1
TR1=TTR2-TTRS
IF (TR1.LT..O.) TR1=0.
IF (TR2.LE..O.) TR2=2000.
10 IF (IN1.EQ.1) SAV=STOPP
STOPP=SAV
FLST=1.0
TLST=START
EHC=HC
EXN=XN
HCSAV=HC
XNSAV=XN
TDC=STOPP/80.
TD=0.
DO 20 I=2f80
TD=TD+TDC
20 SAVTIM(I)=TD
SAVTIM(1)=0.
IF (NPTO.EQ.O) TPRNT=STOPP
IF (NPTO.NE.O) TTM=5.0
H=1.E-10
N=NI
M=NS-1
DO 30 J=l,5
30 ECI(J)=1.
IF (ISP.LE.2) GO TO 60
DO 50 1=3,ISP
DO 40 J=1,M
IF (EMSP(I).EQ.IIHC.OR.EMSP(I).EQ.IINX) GO TO 40
IF (SPECIS(J).NE.EMSP(I)) GO TO 40
ECI(I)=SPRSE(I)
IF (ICR.GT.O.AND.I.GT.2) ECI(I)=SPCR69(1-2)
GO TO 50
40 CONTINUE
50 CONTINUE
60 IFH20=0
IFCO=0
IFISOP=0
IF (N.LE.O) GO TO 80
DO 70 1=1,N
C{I)=CI(I)
IF (REACT(I).EQ.IIH20) IFH20=1
IF (REACT(I).EQ.IICO) IFCO=1
IF {REACT(I).EQ.IISOP) IFISOP=1
70 CONTINUE
80 CONTINUE
IF (IFH20.NE.O) GO TO 90
N=N+1
IF (N.LE.O) N=l
REACT(N)=IIH20
C(N)=H20BK
IF (QW(1).GT.O.) C(N)=QW(1)
90 IF (IFCO.NE.O.OR.ICR.GT.O) GO TO 100
N=N+1
IF (N.LE.O) N=l
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
. 66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
89A
90
91
92
93
94
94A
95
96
97
98
99
100
101
101A
102
103
104
V-2
-------
REACT(N)=IICO
C(N)=COSFBK
100 CALL RATES (C,N)
IF (IN1.NE.O) CALL SPARS (IA,JA,M)
DHC=HCIN-HCBK
DXN=XNIN-XNBK
IF (DHC.LT.O.) HCIN=HCBK
IF (DXN.LT.O.) XNIN=XNBK
DO 110 J=1,NHC
K=IH{J)
FBKS=FINHC(J)
IF (FBK(J).GT.(-0.00001)) FBKS=FBK(J)
C(K)=(HC*RCTY{J)+HCIN*FINHC(J))/CARB(J)
110 CONTINUE
DO 120 K=l,2
I=INOX(K)
IF (SPECIS(I).EQ.IIN02) C(I)=XN*XNF(K)+XNIN
IF (SPECIS(I).NE.IIN02) C(I)=XN*XNF(K)
120 CONTINUE
IF (OZIN.EQ.O.) GO TO 160
DO 130 1=1,NOZ
IF (PLSP(I).NE.II03 ) GO TO 130
JOZ=KOZ(I)
C(JOZ)=OZIN
GO TO 160
130 CONTINUE
140 DO 150 1=1,N
IF (SPECIS(I).NE.II03 ) GO TO 150
C(I)=OZIN
GO TO 160
150 CONTINUE
160 IF (ICR.LE.O) GO TO 190
DO 180 J=1,ICR
DO 170 1 = 1,N
IF (SPECIS(I).NE.ISPNCR(J)) GO TO 170
: C(I)=SURFCR(J)+SPCR69(J)
C(I)=SPCR69(J)
GO TO 180
170 CONTINUE
180 CONTINUE
190 IF (ISP.LE.2.0R.ICR.GT.O) GO TO 195
DO 194 J=3,ISP
DO 193 1 = 1,N
IF (SPECIS(I).NE.EMSP(J)) GO TO 193
IF (SPECIS(I).NE.IICO) GO TO 192
IF (IFCO.NE.O) C(I)=C(I)+SPRSE(J)
IF (IFCO.EQ.O) C(I)=SPRSE(J)
GO TO 194
192 C(I)=C(I)+SPRSEtJ)
GO TO 194
193 CONTINUE
194 CONTINUE
195 IF (IBSP.LE.O) GO TO 199
DO 198 J=1,IBSP
IF (ACB4(J).LE.O.) 30 TO 197
DO 196 L=1,NHC
K=IH(L)
C(K)=C(K)+SURFBI(J)*BFRAC(L,J)/CBTOT(J)
196 CONTINUE
GO TO 198
197 L=IBLS(J)
C(L)=SURFBI(J)
198 CONTINUE
199 CALL DIFFUN (N,START,C,RT,2,START)
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
V
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
140
141
142
143
143A
143B
143C
143D
143E
143F
143G
143H
1431
143J
143K
143L
143M
143N
1430
143P
143Q
143R
143S
143T
143U
143V
143W
144
V-3
-------
HC=HCSAV
XN=XNSAV
IF (NPTO.EQ.O) GO TO 210
WRITE (IOUT,520)
WRITE (IOUT,540) (ITTL(I),1=1, 36)
IF (INFO.LT.l) WRITE (IOUT,600) (PLSP(I),I=1,NOZ)
IF (INFO.LT.l) WRITE (IOUT,610) «INST
-------
ERR=ERRSAV
320 CALL DRIVES (M,T,H,C,TNEXT,ERR,21,IN,IA,JA,YY)
T=TNEXT
IF (NPTO.NE.O) GO TO 350
(T.LT.STOPP) GO TO 220
(INX.GT.(-1)) GO TO 350
(INX.EQ.(-1).AND.OZM(l).GT.0.75*ZN) GO TO 350
(INX.NE.(-3)) GO TO 330
TOL=1.0-(0.17/(SQRT(FLOAT(ITAPE))))
IF (OZM(l).GE.TOL*ZN.AND.OZM(1).LE.ZN/TOL) GO TO 350
330 CONTINUE
IF (INX.NE.(-2)) GO TO 340
IF T.5) WRITE (IOUT,660) HC,XN,RR,OZM(1)
IF
-------
IF (T.EQ.START) TIMNW=START V 271
IF (T.NE.START) TIMNW=TPRNT V 272
CTIME=CLOCK(TCI,IFIX(TIMNW)) V 273
C V 274
C ****** UPDATED 11/81 FOR 24 HR RUNS V 275
C
V 276
IF (CTIME.GT.2400.) CTIME=CTIME-2400. V 277
WRITE (IOUT,620) CTIME,HCC,RNX,CNOX,FN02,(C03(I),1=1,NOZ) V 278
IF (INFO.LE.O) GO TO 460 V 279
WRITE (IOUT,500) (SPECIS(I),1=1,M) V 280
WRITE (IOUT,530) CTIME,(C(I),1=1,10),H,(C(I),1=11,M) V 281
CALL DIFFUN (N,TLMNW,C,RT,1,TIMNW) V 282
WRITE (IOUT,480) (RT(I),1=1,M) V 283
DO 440 1=1,NR v 284
J=KR(I,1) v 285
IF (J.EQ.O) RT(I)=0. V 286
IF (J.EQ.O) GO TO 440 V 287
JT=ITYPE(I) v 288
XT=1. v 289
DO 430 L=1,JT v 290
J=KR(I,L) Y 291
XJ=1. V 292
IF (J.GT.O) XJ=C(J)**ISC(I,L) V 293
IF (ISC(I,L) .EQ. {-!)) XJ=C(J)**SC(I,L) V 294
XT=XT*XJ v 295
430 CONTINUE v 296
RT(I)=XT*R(I) v 297
440 CONTINUE v 298
WRITE (IOUT,490) (RT(I),1=1,NR) V 299
IF (IP.EQ.O) GO TO 460 v 300
DO 450 1=1,IP v 301
K=IPH(I) v 302
450 RX(I)=R(K) v 303
WRITE (IOUT,590) (RX(I),1=1,IP) v 304
WRITE (IOUT,650) HEIGHT,TEMP,ZENI V 305
460 IF (TNEXT.EQ.l.) ERR=AMIN1(1.,100.*ERR) V 306
IF (TIMNW.EQ.START) GO TO 320 V 307
IF (NPTO.NE.O) IN1=1 v 308
IF (T.GE.STOPP) RETURN v 309
TPRNT=TPRNT+TSTEP v 310
GO TO 220 v 311
C V 312
C FORMAT STATEMENTS v 313
C V 314
470 FORMAT (1HO,Fll.5,4X,Fll.5,5X,Fl1.5,5X,5(IP,E12.5,3X)) V 315
480 FORMAT (/10H NET RATES,IX,IP,10E12.3/(11X,IP,10E12.3)) V 316
490 FORMAT (//1X,22HTHE REACTION RATES ARE/UH , IP, 10E13.2) ) V 317
500 FORMAT (//3X,5HTIME ,4X,10(4X,A4,4X)/1X,8HINTERVAL,3X,10(4X,A4, V 318
14X)/(12X,10(4X,A4,4X))) v 319
510 FORMAT (1HO,Fl1.5,4X,Fll.5,5X,Fl1.5,5X,5(IP,E12.5,3X),8H NOT MAX) V 320
520 FORMAT (1H1/) ' V 321
530 FORMAT (/IP,Ell.3,10E12. 37E11.3,10E12.3/(11X,10E12.3)) V 322
540 FORMAT (46X,36A2) • V 323
550 FORMAT (1HO,Fl1.5,F9.5,Fll.5,2X,4(IP,E10.4,3X,OP,F5.0,2X),IP, V 324
1E10.4,3X,OP,F5.0) v 325
560 FORMAT (24HOTHE ERROR TOLERANCE IS ,1P,E10.3/ V 326
125HOTHE TEMPERATURE USED IS ,E10.3/ Y 327
221HOTHE MIXING HEIGHT IS ,E10.2) V 328
570 FORMAT (29HOTHE RATE CONSTANTS USED WERE//(1HO,IP,10E13 3)) V 329
580 FORMAT (29HOTHE PHOTOLYSIS REACTIONS ARE/(1HO,9113)) V 330
590 FORMAT (34HOTHE PHOTOLYTIC RATE CONSTANTS ARE/<5X,IP,9E13 3)) V 331
600 FORMAT (1HO,10X,4HTIME,6X,4HNMOC, 7X, 5HNMOC/, 8X, 3HNOX, 9X,3HN02,9X,V 332
1A4,4(8X,A4)) Y 333
610 FORMAT(1 OX,6H(LOT ),4X,5HTOTAL,8X,3HNOX,8X,5HTOTAL,6X,8HFRACTION, V 334
V-6
-------
13X,5(3A4))
V 336
V
, v
130HOTHE CURRENT TEMPERATURE IS ,F10.2/ ' v
230HOTHE CURRENT ZENITH ANGLE IS ,F10.2) v
660 FORMAT (1HO, 4F20 .5, F21 .0) X
670 FORMAT (1HO, 4F20 . 5, 14X, 7HNOT MAX)
650 FORMAT (//30HOTHE CURRENT MIXING HEIGHT IS ,F10 2/
'
680 FORMAT (lXr7E13.4)
,
,
690 FORMAT (1X,F8.5, 2X, F8.5, 2X,F8.5r 3X, 5 (IP, E8.5,2X) ) v 346
"'
a:
V 350
)'4X'5HTOTAL'8X'3HNOX'8X'5H1'OTAL,6X,8HFRACTION, V 352
'1X;f6-°'1X'F10-5'2X'F10-5-2X,F10.5,2X,F10.5,2X,F10.5, V
,l? 1U . 5) ) ..
750 FORMAT (IX, 4F10 . 5, Fll . 0) „
760 FORMAT (IX, 4F10 . 5, 4X, 7HNOT MAX)
END
V
V 358-
V-7
-------
SUBROUTINE DRIVES (N, TO, HO, YO, TOUT, EPS, MF, INDEX, IA, JA, Y) W 1
W 2
C THIS IS THE DRIVER ROUTINE FOR THE GEAR INTEGRATION SCHEME W 3
C W 4
C REF: SPELLMANN AND HINDMARSH (1975) W 5
SAVE JJ *
COMMON /CNTRL/ SIG, SIGMA, INFO, NPTO,TSRT, DTIM, Zl, Z2,DCON, EHC, EXN, W 8
1 FLST,TLST w 9
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20), INOX(2), W 10
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN, W 11
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5) W 12
COMMON /HJH/ HCSAV,XNSAV w 13
COMMON /GEAR1/ T, H, HMIN, HMAX, EPSC, UROUND, NC, MFC, KFLAG, JSTART W 14
COMMON /GEAR2/ YMAX(IOO) / GEAR3/ ERROR ( 100) /GEAR4/W1 (60, 3) W 15
COMMON /GEARS/ IW1(61,9) /GEAR6/W2 (2400) /GEAR7/IW2 (2400) W 16
COMMON /GEARS/ EPSJ, IPTI2, IPTI3, IPTI4, IPTR2, IPTR3, NGRP W 17
COMMON /GEAR9/ HOSED, NQUSED, NSTEP, NFE, NJE, NZA, NPL, NPU, NZL, NZU, NZROW 18
COMMON /INOUT/ INP, LOUT, ITAPE, IALN, IALL, INHH, IOZC W 19
W 19A
COMMON /CALCHR/ SPECIS(61) w 19B
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT (61) W 19C
CHARACTER* 4 SPECIS, HCSPEC, . REACT, PLSP W 19D
W 1 9F
DIMENSION IA(1), JA(1), YO (N) w 20
DIMENSION Y(N,6) JJ 21
DATA NMX/60/,LENW2/2400/,LENIW2/2400/ w ??
NGP=0 2 H
IF (INDEX. EQ. 4) GO TO 30 w 2l
IF (INDEX. EQ.O) GO TO 60 w ?fi
IF (INDEX. EQ. 2) GO TO 70 w 21
IF (INDEX. EQ. (-1)) GO TO 80 W ?fl
IF (INDEX. EQ. 3) GO TO 90 w ™
IF { INDEX. NE.l) GO TO 270 w tg
IF (EPS.LE.O.) GO TO 240 w ,,
IF (N.LE.O) GO TO 250 w ^
IF ((TO-TOUT)*HO.GE.O.) GO TO 260 w q -,
MLTER=MF-10MMF/1C) w 3^
IF ( (MITER. NE.l) .AND. (MITER. NE . 2)) GO TO 30 w ^ s
NZA=IA(NP1)-1
• MAX=LENIW2/2 w ^'
IPTI2-MAX+1 JJ 33
CALL SORDER (N, IA, JA, IW1, IW1 ( 1 , 5 ) , MAX, IW2, IW2 ( IPTI2) , IER) W 40
IPTI2=NZA+1 W 41
IF (IPTI2+NZA-1.GT.LENIW2) GO TO 290 w 4,
DO 10 1=1, NP1 ^
10
DO 20 1=1, NZA
20 IW2(I)=JA(I) JJ \l
^CALL NSCORD (N, IW1 (1 , 2) , IW2, IW1 ( 1, 3) , IW2 (IPTI2) , IW1, IW1 ( 1, 5) , IW1 ( 1W 47
MAXPL=(LENIW2-NZA)/2 JJ \\
IPTI3=IPTI2+MAXPL w ?*
MAXPU=LENIW2-IPTI3 + 1
(N'IW1(1'2)'IW2'MAXPL'IWK1,3),IW2(IPTI2),IW1(1,4),MAXW 52
(lf5),IW2(IPTI3),IWl(l,6),Y(l,6),IWl(l,9),Y,Y(l,2),Y(l,3),IWW 53
21(1, 7), IW1(1, 8), Y(l, 4), Y(l, 5), IER) w S4
NPL=IW1(N,4) J ll
NPU=IW1(N,6) J: II
NZL=IW1(N+1,3) „ ^
NZU-IWl(N+lf5) JJ I'
IPTR2=NZA+1 JJ II
W-l
-------
IPTR3=IPTR2+MAXO(NZA,NZL) w
IF (IPTR3+MAXO(NZA,NZU)-1.GT.LENW2) GO TO 290 w *i
30 DO 40 1=1,N |! It
YMAX(I)=ABS(YO(I))
IF (YMAX(I).EQ.O.) YMAX(I)=1.E-10 W
40 Y(I,1)=YO(I)
NHCUT=0
W 64
NC=N ?J 65
T=TO ^
H=H° W 68
NZRO=0 W 58
TST=EPS*1.E-10 JJ 69
DO 50 1=1,N JJ 7°
50 IF (Yd, 1) .GT.TST) NZRO=NZRO+1 JJ L~
NZRO=MAXO(NZRO,1) ?! ',
NOLD=NZRO JJ 73
HMIN=ABS(HO) ?! ~\
HMAX=ABS (TO-TOUT) *10. JJ Z
HMAX=AMIN1(HMAX,20.) JJ 7^
EPSC=EPS JJ '
MFC=MF JJ 78
JSTART=0 j 79
NO=N ?J 80
CALL OZMX (Y,TL,TOUT,NO) JJ ?J
NMX1=NMX+1 ' JJ - 82
EPSJ=SQRT(UROUND)
W 84
W 85
GO TO 100
60 HMAX=ABS(TOUT-TOUT?)*10. JJ ??
HMAX=AMIN1(HMAX,20.) JJ 87
GO TO 160 JJ 88
70 HMAX=ABS(TOUT-TOUTP)*10. JJ "
HMAX=AMIN1(HMAX,20.) ' JJ 9°
IF ((T-TOUT)*H.GE.O.) GO TO 300 JJ ?:
GO TO 170 W 92
80 IF ((T-TOUT)*H.GE.O.) GO TO 280 !! I]
JSTART=-1 „ ll
NC=N W 95
EPSC=EPS W 96
TST=EPS*1.E-10 !J 97
MFC=MF W 98
90 CONTINUE W "
100 CONTINUE W 3-??
CALL STIFFS (Y, NO, IA, JA, Wl, NMX, IW1, NMX1) !!
JOZ=KOZ(1) W
KGO=1-KFLAG W l°_3
GO TO (110,190,220,200),KGO Jl
110 CONTINUE f W
IF (T.GE.TL) CALL OZMX (Y,TL,TOUT,NO) M
D=0. w
NZRO=0 W 108
DO 140 1=1,NC W }?9
IF (Y(I,1) .GE.O.) GO TO 130 J!
NGP=NGP+1 W
DO 120 J=l,6 W
C K=(J-1)*N+I W
C 120 Y(K,1)=0. W
120 Y(I,J)=0. W
130 CONTINUE W 115
IF (Y(I,1).GT.TST) NZRO=NZRO+1 f!
AYI=ABS(Y(I,1)) W
YMAX(I)=AMAX1(1.E-10,AYI) W
140 D=D+(AYI/YMAX(I))**2 W
NZRO=MAXO(NZRO,1) W
DO 150 11=1,NC W 121
W 122
W-2
-------
150 YO(II)=Y(II,1)
CALL SAVIT (T,YO)
IF {NZRO.NE.NOLD} JSTART=-1
IF {NZRO.NE.NOLD) NOLD=NZRO
D=D*(UROUND/EPS)**2
IF {D.GT.FLOAT(N)) GO TO 230
IF (INDEX.EQ.3) GO TO 300
IF (INDEX.EQ.2) GO TO 170
160 IF ((T-TOUT)*H.LT.O.) GO TO 90
CALL INTERP (TOUT,Y,NO,YO)
GO TO 320
170 IF (T.GE.TOUT) GO TO 180
IF (((T+H)-TOUT).LE.1..AND.T.GT.1.) GO TO 90
H={TOUT-T)*(1.+4.* UROUND)
JSTART=-1
GO TO 90
180 JSTART=-1
H=AMIN1{H,,1.)
GO TO 300
190 CONTINUE
200 IF (NHCUT.EQ.10) GO TO 210
NHCUT=NHCUT+1
HMIN=.1*HMIN
H=.1*H
JSTART=-1
GO TO 90
210 WRITE (LOUT,330)
IF (KGO.EQ.4) WRITE (LOUT,360) T
STOP
220 WRITE (LOUT,340) T,H
STOP
230 WRITE (LOUT,350) T
KFLAG=-2
STOP
240 WRITE (LOUT,370)
STOP
250 WRITE
STOP
260 WRITE (LOUT,390)
STOP
270 WRITE
STOP
280 WRITE
STOP
290 WRITE
STOP
300 TOUT=T
DO 310 1=1,N
310 YO(I)=Y(I,1)
CALL SAVIT (TOUT
320 INDEX=KFLAG
TOUTP=TOUT
HO=HUSED
IF (KFLAG.NE.O) HO=H
RETURN
FORMAT STATEMENTS
330 FORMAT (//44H PROBLEM APPEARS UNSOLVABLE WITH GIVEN INPUT//)
340 FORMAT (//35H KFLAG = -2 FROM INTEGRATOR AT T = ,E16.8,5H H = E16W
1.8/52H THE REQUESTED ERROR IS SMALLER THAN CAN BE HANDLED//) '
350 FORMAT (//37H INTEGRATION HALTED BY DRIVER AT T = ,E16 8/56H EPS
1TOO SMALL TO BE ATTAINED FOR THE MACHINE PRECISION/)
360 FORMAT
-------
1TOR CONVERGENCE COULD NOT BE ACHIEVED/)
370 FORMAT {//28H ILLEGAL INPUT.. EPS .LE. O.//)
380 FORMAT (//25H ILLEGAL INPUT
390 FORMAT (//36H ILLEGAL INPUT
400 FORMAT (//24H ILLEGAL INPUT
N .LE. O//)
(TO-TOUT)*H .GE. O.//)
INDEX =,I5//)
410 FORMAT (//44H INDEX = -1 ON INPUT WITH (T-TOUT)*H GE 0 /4H T = EW
116.8,9H TOUT -,E16.8,6H H =,E16.8) * JJ
420 FORMAT {//42H INSUFFICIENT WORKING STORAGE IN IW2 OR W2//) w
END
W
187
188
189
190
191
192
193
194
195-
W-4
-------
SUBROUTINE STIFFS (Y,NO,IA,JA,W1,NMX,IW1,NMX1)
C
C THE GEAR PREDICTOR/SOLVER ROUTINE FOR STIFF EQUATIONS
C
SAVE
COMMON /GEAR1/ T,H,HMIN,HMAX,EPS,UROUND,N,MF,KFLAG,JSTART
COMMON /GEAR2/ YMAX(IOO) /GEAR3/ERROR(100)
COMMON /GEAR6/ W2(2400) /GEAR7/IW2(2400)
COMMON /GEARS/ EPSJ,IPTI2,IPTI3,IPTI4,IPTR2,IPTR3,NGRP
COMMON /GEAR9/ HUSED,NQUSED,NSTEP,NFE,NJE,IDUMMY(5),NZRO
COMMON /HEAT/ SC (200,12),ISC(200,3)
COMMON /CALC/ NR,KR(200,12),A(200),S(200),R(200),ITYPE(200),
1 IB(60),JB(800),DILUT,TEMP,ERR,START,STOPP,TPRNT,
2 TSTEP,ZENI
COMMON /PHOTON/ CF(72,20),PX(24,20),IPH(20),IP,RFCT(20),PP(10,20)
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10),
2 IDPTIM,DPEND,RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /CALCHR/ SPECIS(Sl)
CHARACTER*4 SPECIS
DIMENSION
DIMENSION
Y(NO,6),
EL(13), TQ(4)
RT{3)
W1(NMX,3), IW1(NMX1,9)
DATA EL(2)/1./,OLDLO/1./
KFLAG=0
TOLD=T
IF (JSTART.GT.O) GO TO 100
IF (JSTART.NE.O) GO TO 20
CALL DIFFUN (N,T,Y,Wl,1,TOLD)
DO 10 1=1,N
10 Y(I,2)=H*W1(I,1)
METH=MF/10
MITER=MF-10*METH
NQ=1
L=2
IDOUB=3
RMAX=1.E4
RC=0.
CRATE=1.
HOLD=H
MFOLD=MF
NSTEP=0
NSTEPJ=0
NFE=1
NJE=0
IRET=3
GO TO 30
20 IF (MF.EQ.MFOLD) GO TO 50
MEO=METH
MIO=MITER
METH=MF/10
MITER=MF-10*METH
MFOLD=MF
IF (MITER.ME.MIO) IWEVAL=MITER
IF (METH.EQ.MEO) GO TO 50
IDOUB=L+1
IRET=1
30 CALL COSET (METH,NQ,EL,TQ,MAXDER)
LMAX=MAXDER+1
RC=RC*EL(1)/OLDLO
OLDLO=EL(1)
40 FN=FLOAT(NZRO)
EDN=FN*(TQ(1)*EPS) **2
X
X
X
X
X
X
X
X
X
X
X
X
X
X
,x
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
1
2
3
4
5
6
7
8
9
10
11
12
12A
13
14
15
16
16A
16B
16C
16D
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
X-l
-------
E=FN*(TQ{2)*EPS)**2
EUP=FN*(TQ(3)*EPS)**2 X 60
BND=FN*(TQ(4)*EPS)**2 v !i
EPSOLD=EPS X 62
NOLD=NZRO X 63
GO TO (60,70,100),IRET * "
50 IF (EPS.EQ.EPSOLD..AND.NZRO.EQ.NOLD) GO TO 60 v c*
IRET=1 * bb
GO TO 40 X 67
60 IF (H.EQ.HOLD) GO TO 100 X !®
RH=H/HOLD X 69
H=HOLD X 70
IREDO=3 X 71
GO TO 80 X 72
70 RH=AMAX1(RH,HMIN/ABS(H)) * 2?
80 RH=AMIN1(RH,HMAX/ABS(H),RMAX) * 15
DO 90 J=2,L X 76.
R1=R1*RH X 77
DO 90 1=1,N X 78
90 Y(I,J)=Y(I,J)*R1 X '*
H=H*RH X 80
RC=RC*RH X 81
IDOUB=L+1 X 82
IF (IREDO.EQ.O) GO TO 550 * ?J
100 IF (ABS(RC~1.).GT.0.3) IWEVAL=MITER C !f
IF (NSTEP.GE.NSTEPJ+20) IWEVAL=MITER C o^
T=T+H A Bb
DO 110 J1=1,NQ X 87
DO 110 J2=J1,NQ X 88
J=(NQ+J1)-J2 X °9
DO 110 1=1,N X 90
110 Y(I,J)=Y(I,J)+Y(I J+l) X 91
120 DO 130 1=1,N X 92
IF (Y(Ifl).LT.l.E-5) GO TO 130 C- "
IF (Y(I,1).LT.(-2.*Y(I,2))) GO TO 290 C- „
130 ERROR(I)=0. * yb
M=0 X 96
CALL DIFFUN
-------
DO 210 K=1,MT y
I=KR(IR,K) £
DO 170 L=1,MT I)
J=KR(IRfL) £
M=IA(J)-1 *
160 M=M+1 * 12°
IF (I-JA(M)) 160,170,160 J
170 W2(M)=W2(M)-RT(L) *
DO 200 L-4,12 *
j=KR(iR,D
IF (J) 200,210,180 0
180 M=M+1
IF (J-JA(M)) 180,190,180 C
190 W2(M)=W2(M)+RT(K)*SC(IR,L) 0
200 CONTINUE Q
210 CONTINUE J
220 CONTINUE *
DO 240 J=lrN J
KMIN=IA(J) J
KMAX=IA(J+1)-1 J
DO 230 K=KMIN,KMAX y
W2(K)=W2(K)*CON £
IF (JA(K).EQ.J) W2(K)=W2(K)+1.-CON*DILOT-CON*DNOWS X
230 CONTINUE *
240 CONTINUE !!
150
152
(IPTI3)'IW1<^6),W2(IPTR3),W1,IW1(1,7),IW1X 153
,
M=ISV £
L=LSV X
IF (IER.NE.O) GO TO 290 0
250 DO 260 1 = 1, N C.
260 W1{I,1)=H*W1(I,2)-(Y(I,2)+ERROR(I)) X 159
(1'3) ' IW2 (IPTI2) ' IW1 (1, 4) , W2 (IPTR2) , Wl (IX 160
^{IPTI3),IW1(1,6),W2(IPTR3),W1{1,2),W1,W2) X 161
DO 270 1 = 1, N y
ERROR(I)=ERROR(I)+W1(I,2) y
D=D+(W1(I,2)/YMAX(I))**2 J
270 Wl(Ifl)=Y(Ifl)+EL(l)*ERROR(I) £
IF (M.NE.O) CRATE=y\MAXl(.9*CRATE,D/Dl) y
IF ((D*AMINl(l.f2.*CRATE)).LE.BND) GO TO 320 v
D1=D
M=M+1 X 169
IF (M.EQ.3) GO TO 280 *
CALL DIFFUN (N, T, Wl, Wl (1 , 2) , 1 , TOLD) y
GO TO 250 X
280 NFE=NFE+2 X 173
IF (IWEVAL.EQ. (-1)) GO TO 310 v
290 T=TOLD A
RMAX=2. X 176
DO 300 J1 = 1,NQ X
DO 300 J2=J1,NQ X
J=(NQ+J1)-J2 X
DO 300 1=1, N X 18°
300 Y(IJ)=YIJ
IF (ABS(H) .LE.HMIN*!. 00001) GO TO 540 v
RH=.25 X
IREDO=1 X
GO TO 70 X 185
310 IWEVAL=MITER X 186
X 187
X-3
-------
GO TO 120
320 IF (MITER.NE.O) IWEVAL=-1 Y
NFE=NFE+M X
D-0. X 19°
DO 330 1=1,N X
330 D=D+(ERROR(I)/YMAX{I))**2 Y
IF (D.GT.E) GO TO 360 Y , Q ,
KFLAG=0 * iy4
IREDO=0 X ll5
NSTEP=NSTEP+1 * ;„
HUSED=H X
NQUSED=NQ X
D0 340 J=1,L X J99
DO 340 1=1,N J
340 Y(I,J)=Y(I,J)+EL(J)*ERROR(I) Y
IF (IDOUB.EQ.l) GO TO 380 Y
IDOUB=IDOUB-1 y
IF (IDOUB.GT.l) GO TO 560 Y
IF (L.EQ.LMAX) GO TO 560 Y
DO 350 1=1,N J
350 Y(I,LMAX)=ERROR(I) X
GO TO 560 X
360 KFLAG=KFLAG-1 *
T=TOLD
DO 370 J1=1,NQ
DO 370 J2=J1,NQ
J=(NQ+J1)-J2
DO 370 1=1,N
370 Y(I,J)=Y(I,J)-Y(]
RMAX=2.
IF (ABS(H).LE.HMIN*!.00001) GO TO 520 v
IF (KFLAG.LE.(-3)) GO TO 500 0
IREDO=2 A
PR3=1.E+20 X 220
GO TO 400 X 221
380 PR3=1.E+20 „ ???
IF (L.EQ.LMAX) GO TO 400
Dl=0.
DO 390 1=1,N
390 Dl=Dl+{(ERROR(I)-Y[I,LMAX))/YMAX(I))**2
ENQ3=.5/FLOAT(L-fl)
PR3 = ((D1/EUP)**ENQ3) * 1.4 + 1.4E-6 Y ,,Q
400 ENQ2=.5/FLOAT(L) 0 ^
PR2={(D/E)**ENQ2)*1.2+1
PR1=1.E+20
IF (NQ.EQ.l) GO TO 420 v ooo
D=0. X 233
DO 410 1=1,N X 234
410 D=D+(Y(I,L)/YMAX(I))**2 Y
ENQ1=.5/FLOAT(NQ) Q
PRl=((D/EDN)**ENQl)*1.3+1.3E-6 Y
420 IF (PR2.LE.PR3) GO TO 430 Y
IF (PR3.LT.PR1) GO TO 450 v
GO TO 440 X 24°
430 IF (PR2.GT.PR1) GO TO 440 Y
NEWQ=NQ X
RH=1./PR2 X
GO TO 480 X 244
440 NEWQ=NQ-1 X 245
RH=1./PR1 X 246
GO TO 480 X247
450 NEWQ=L X 248
RH=1./PR3 X 249
IF (RH.LT.1.1) GO TO 470 Y oc?
X 2 j 1
X-4
-------
DO 460 1=1, N
460 Y(I,NEWQ+1)=ERROR(I)*EL(L)/FLOAT(L)
GO TO 490
470 IDOUB=10
GO TO 560
480 IF ((KFLAG.EQ.O).AND.(RH.LT.1.1)) GO TO 470
IF (NEWQ.EQ.NQ) GO TO 70
490 NQ=NEWQ
L-NQ+1
IRET=2
GO TO 30
500 IF (KFLAG.EQ.(-9)) GO TO 530
RH=10.**KFLAG
RH=AMAX1(HMIN/ABS(H),RH)
H=H*RH
CALL DIFFUN (N, T, Y, Wl, 1, TOLD)
NFE=NFE+1
DO 510 1=1,N
510 Y(I,2)=H*W1(I,1)
IWEVAL=MITER
IDOUB=10
IF (NQ.EQ.l) GO TO 100
NQ=1
L=2
IRET=3
GO TO 30
520 KFLAG=-1
GO TO 560
530 KFLAG=-2
GO TO 560
540 KFLAG=-3
GO TO 560
550 RMAX=100.
560 HOLD=H
JSTART=NQ
RETURN
END
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
X
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288-
X-5
-------
SUBROUTINE DIFFUN (L,T,X,XT,IENTRY,TXLD)
SAVE
COMMON /CALC/
NR,KR(200,12),A(200),S(200),R(200),ITYPE(200),
IA(60),JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT
I TSTEP,ZENI
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTO,TSRT,DTIM,Zl,Z2,DCON,EHC,EXN
COMMON /SPEC/
COMMON /HEAT/
COMMON /NEEDI/
FLST,TLST
NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN
XNAL,NOZ,FENX(2),C(61),NI,KOZ<5)
SC(200,12),ISC(200,3)
IBLANK,MBLANK,IIHC,IINX,IICO,IIN02,UNO,I103,
IIH20,JPLUS
ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),XZ(24)Y
rKKl(24),JSRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,MAXJ
COMMON /PHOTON/ CF (72,20),P(24,20),IPH(20),IP,RFCT(20),PP(10,20)
1 IDEPO,RDEPO(26,10),LOCDEP(10),RDCOEF(125,10),
rnMM^M ,. , IDPTIM'DPEND'RDEP1(26,10),DNOWS,SPRSE(300)
COMMON /EMIS/ NEM,IS1,ESTRT(5),ESTOP,ESLP,IEMLS(5),EOSLP(5)
* EMO<26,5),ECI(5),EM(26),EC(125),ES(125,5)
COMMON /MIX/ NMIX,AMIX(26),STRM,STOPM,DC(104)
COMMON /MIXING/ DSTRT,DEND,AMC(5),BMC(5),CMC(5),FD(6),FG(6)
1 AMXX(26),DL,TTMAX,SRISE,SRMIN,DELH,TOIL, NMXX,HT,
° SSET,SSRISE
IALFT,CALFT(10),LOCALF(10)
ICR, ISPCR,SPCR69(3),SURFCR(3),ALOFCR(3),
REDCR(3),FSRFCR(3),FALFCR(3) , COSFBK,COAFBK
NBEM,IBSP,WTMOL(5),ACB4(5),SURFBI(5),
ALOFBI(5),REDBI(5),FSRFBI(5),FALFBI(5),BEMO(26,5),Y
BECO(126,5),CBTOT(5),IBLS(5),BESTOP,BFRAC(20,5)
WATEND,NWATER,PAMB,QW(30),QR(30),PMILLI,ILH20
COMMON /ALOFT/
COMMON /CRED/
L
COMMON /BIOG/
COMMON /WATER/
COMMON /ALFCHR/ ISPAL(IO)
COMMON /BIOCHR/ IISOP, IBEMSP(5)
COMMON /CRECHR/ ISPNCR(3)
COMMON /EMSCHR/ EMSP(5)
COMMON /NEED1C/ IBZA
COMMON /PHTCHR/ ISPDP(IO)
COMMON /CALCHR/ SPECIS(61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*4 SPECIS, HCSPEC, REACT, PLSP
CHARACTERM ISPAL, ISPDP, ISPNCR, IBEMSP
CHARACTERM IISOP, EMSP
CHARACTERM IBLANK, MBLANK, IIHC, IINX, IICO, IIN02, UNO, 1103
IIH20,IBZA,JPLUS
EMULATE MULTIPLE ENTRY WITH COMPUTED GO TO
GO TO (10,380),IENTRY
MAIN ENTRY POINT
10 CONTINUE
N=L
Y
Y
Y
Y
Y
Y
Y
Y
Y
, Y
Y
Y
, Y
Y
Y
Y
Y
Y
Y
Y
4)Y
Y
, Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
,Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
1
2
3
4
5
6
7
8
8A
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
28A
29
30
31
32
32A
32B
32C
32D
32E
32F
32G
32H
321
32J
32K
32L
32M
32N
320
32P
32Q
32R
32S
32T
33
34
35
36
37
38
39
40
41
42
Y-l
-------
DILO=DILUT Y 43
IF(T.LT.TSRT.OR.TXLD.GT.TSRT+DTIM) DILU=0. Y 44
IF(T.LT.TSRT.OR.TXLD.GT.TSRT+DTIM) GO TO 60 Y 45
IF (AMIX(l).GT.(-l.)) GO TO 50 Y 46
TT=CLOCK(TCI,IFIX(T)) Y 47
TT=CLKMIN(TT) Y 48
TT«TT-SRISE Y 49
FDT=TT/DL Y 50
IF(FDT.LT.O.O) FDT=0.0 Y M
K=0 * H
20 K=K+1 Y 53
IF(FDT.GE.FD(K).AND.FDT.LT.FD(K+l)) GO TO 30 Y 54
IF(K.LT.S) GO TO 20 . Y 55
IF(FDT.LT.FD(2)) GO TO 40 Y 56
FGG=1.0 Y 5 7
FGSLP=0.0 Y 58
GO TO 40 Y 59
30 CONTINUE Y 6Q
XFD=FDT-FD(K) Y 61
FGG=((AMC(K)*XFD+BMC(K))*XFD+CMC(K))*XFD+FG(K) Y 62
FGSLP=(3.*AMC(K)*XFD+2.*BMC(K))*XFD+CMC(K) Y 63
40 HT=SRMIN+FGG*DELH Y 64
DILU=(FGSLP*DELH)/(HT*DL) Y 65
GO TO 60 Y 66
50 IF (AMIX(l).LT.O.) GO TO 60 Y 67
E Y 68
C CALCULATE DILUTION FOR CURRENT TIME STEP Y 69
C Y 70
I=IFIX(T/60.+1.9999995) Y 71
IF (T.LE.TOLD.AND.I.LT.IOLD) I=IOLD Y 72
IOLD=I Y 73
IF (I.LE.l) 1=2 Y 74
Z=T-FLOAT{]>2)*60. Y 75
HT=((Z*DC(3*I-3)+DC(3*I-4))*Z+DC(3*I-5))*Z+AMIX(I-l) Y 76
DILU=((3.0*Z*DC(3*I-3)+2.0*DC(3*I-4))*Z+DC(3*I-5))/HT Y 77
60 DILUT=AMAX1(DILU,0.) y 78
TNOW=TEMP Y 7g
ZNOW=ZENI Y 80
DO 70 1=1,N Y 81
XT(I)=-DILUT*X(I) Y 82
IF (SPECIS(I).EQ.IICO) XT(I)=XT(I)+DILUT*COAFBK Y 83
IF (SPECIS(I) .EQ. IIH20 ) XT(I)=XT(I)+DILUT*X(I) Y 84
70 IF (SPECIS(I).EQ.II03 ) XT(I)=DILUT*(OZAL-X(I)) Y 85
IF (T.LT.TSRT.OR.T.GT.TSRT+DTIM) GO TO 140 - Y 86
DO 80 K=l,2 Y 87
J=INOX(K) Y 88
IF (SPECIS(J).NE.IEN02 ) GO TO 80 Y 89
XT(J)=DILUT*(XNAL-X(J)) Y 90
GO TO 90 Y g]
80 CONTINUE Y 92
90 DO 100 K=1,NHC Y 93
J-IH(K) Y 94
FBKS=FALHC(K) y 95
IF (FBK(K) .GT. (-0.00001)) FBKS=FBK(K) Y 96
XT(J)=DILUT*(FALHC(K)*HCAL/CARB(K)-X(J)) Y 07
100 CONTINUE v '
.-, i y b
Y 99
C ENTRAIN OTHER SPECIES y
IF (IALFT.LE.O) GO TO 120 Y
DO 110 K=1,IALFT Y in
J=LOCALF(K) Y 104
XT(J)=DILUTMCALFT(K)-X(J) ) Y ins
110 CONTINUE v :^
i 1U o
Y-2
-------
120 IF (ICR.LE.O) GO TO 131
DO 130 JJ=1,ICR
J=IEMLS(JJ+2)
XT(J)=DILUT*(ALOFCR(JJ)-X(J))
130 CONTINUE
131 IF (IBSP.LE.O) GO TO 140
DO 134 J=1,IBSP
IF (ACB4(J).LE.O.) GO TO 133
DO 132 LL=1,NHC
K-IH(LL)
XT(K)=DILUT*(FALHC(LL)*HCAL/CARB(LL)+ALOFBI(J)*
1 BFRAC(LL,J)/CBTOT(J)-X(K))
132 CONTINUE
GO TO 134
133 K=IBLS(J)
XT(K)=DILUT*(ALOFBI(J)-X(K))
134 CONTINUE
INPUT EMISSIONS
140 IF (T.GE.ESTOP) GO TO 221
FNOW=Z1/HT
IF (AMIX(l).GE.O.) FNOW=AMIX(1)/HT
150 I=IFIX(T/60.)
ENOW=0.
ZZ=(T-FLOAT(I*60))/60.
•*• \ J. i j. / ^
IF (NEM.GT.O) ENOW=((((ZZ*EC(I)+EC(I-l))*ZZ+EC(I-2))*ZZ+EC(I-3
1))*ZZ+EC(I-4))*FNOW/60.
DO 160 J=1,ISP
IF (NEM.GT.O.AND.J.LE.2) ENOWS(J)=ENOW
IF (NEM.LE.-l)
1ENOWS(J) = ((((ZZ*ES(I,J)+ES(1-1,J))*ZZ+ES(1-2,J))*ZZ
2 +ES(I-3,J})*ZZ+ES(I-4,J))*FNOW/60.
160 CONTINUE
DO 220 LL=1,ISP
IF (EMSP(LL).NE.IINX ) GO TO 190
DO 180 K=l,2
J=INOX(K)
XT (J) =XT (J) H-ENOWS (LL) *EXN*FENX (K)
GO TO 220
IF (EMSP(LL).NE.IIHC ) GO TO 210
DO 200 K=1,NHC
J=IH(K)
200 XT(J)=XT(J)+ENOWS(LL)*EHC*RCTY(K)/CARB(K)
GO TO 220
210 J=IEMLS(LL)
XT(J)=XT(J)+ENOWS(LL)*ECI(LL)
220 CONTINUE
221 IF (IBSP.LE.O) GO TO 230
IF (T.GE.BESTOP) GO TO 230
FNOW=Z1/HT
IF (AMIX(l).GE.O.) FNOW=AMIX(1)/HT
I=IFIX(T/60.)
ZZ=(T-FLOAT(I*60))/60.
170
180
190
DO 222 J=1,IBSP
ENWS1(J)=((((ZZ*BECO(I,J)+BECO(I-1,J))*ZZ+BECO(I-2,J))*ZZ
1 +BECO(I-3,J))*ZZ+BECO(I-4,J))*FNOW/60
222 CONTINUE
DO 225 J=l,IBSP
IF (ACB4(J).LE.O.) GO TO 224
DO 223 LL=1,NHC
K=IH(LL)
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
Y
107
108
109
110
111
111A
111B
111C
HID
HIE
111F
111G
111H
1111
111J
111K
11 1L
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
143A
143B
143C
143D
143E
143F
143G
143H
1431
143J
143K
143L
143M
143N
1430
Y-3
-------
223
224
225
C
C DO
C
230
231
240
250
251
260
270
XT(K)=XT(K)+ENWS1
-------
1 , -. -.
1 -QM
-------
ENTRY DIFSET y 242
380 CONTINUE Y 243
TOLD=T Y 244
•TINV-1./60. Y 245
FCT=((3355.7046E-6)*TEMP-1.)/TEMP y 246
IOLD=0 Y 247
TCI=FLOAT{JSRT) Y 248
DHC=HCAL-HCBK . Y 249
DXN=XNAL-XNBK Y 250
D03=OZAL-OZBK Y 251
IF (DHC.LT.O.) HCAL=HCBK y 252
IF (DXN.LT.O.) DXN=0. Y 253
IF (D03.LT.O.) D03=0. y 254
HT=AMIX(1) Y 255
IF (HT.LT.O.) HT=AMXX(1) Y 256
IF (IP.EQ.O) RETURN y 257
IPST=0 Y 257A
IBST1=0 Y 257B
IBST2=0 Y 257C
11=0 Y 258
DO 390 J=1,IP Y 259
IR=IPH(J) Y 260
R(IR)=P{1,J)*RFCT(J) Y 261
IF M.GT.l) R(IR)=R(IR)*R(1) Y 262
IF (R(IR).LT.O.) R(IR)=0. Y 263
390 CONTINUE Y 264
ZENI=XZ(1) v
ISP=IS1+ICR Y 265A
RETURN Y 266
END Y 267-
Y-6
-------
SUBROUTINE COSET (METH,NQ,EL,TQ,MAXDER) z 1
C PART OF THE GEAR ROUTINES 5 \
C Z 3
SAVE ^ \
DIMENSION PERTST(12,2,3), EL(13), TQ(4) Z
,,, , Z 6
/*-1-'2-'1-' -3158,. 07407,. 01391, .002182,. 0002945,. OOOOZ 7
,. 0000003524, 1. , 1 . , .5, . 1667, . 04167, 1. , 1 . , 1. , 1 . , 1 , 1Z 8
9
n ../.f.f.r 10
. 33, 70. 08, 87. 97, 106. 9, 126.7, 147.4, 168. 8r 191. 0,1., 3. 0,6. 0,9. 167, 1Z 11
.5,l.,l.,l.,l.,l.,l.ri.fi./ 7 19
10 MAXDER=5 ^ ^
GO TO (20,30, 40, 50,60), NQ 7 \\
20 EL(1)=1.0 L \\
GO TO 70 * :^
30 EL(1)=6.6666666666667E-01 ! }l
EL(3)=3.3333333333333E-01 7 to
GO TO 70 |g
40 EL(1)=5.4545454545455E-01 7 i?
EL(3)=EL(1) 7 ;"
EL(4)=9.0909090909091E-02 7 „
GO TO 70 *i
so EL(i)=o.48 J ;;
EL{3)=0.7 J 24
EL(4)=0.2 J II
EL(5)=o.o2 L ;;
GO TO 70 '7 9«
60 EL(1)=4.3795620437956E-01 7 ^
EL(3)=8.2116788321168E-01 f ^
EL(4)=3.1021897810219E-01 7 ^
EL(5)=5.4744525547
-------
FUNCTION CLKMIN (X) AA 1
C CALCULATE THE NUMBER OF MINUTES BASED ON A 24 HR CLOCK AA 3
C AA 4
SAVE AA 5
JSTRT=IFIX(X+0.1) AA 6
JMIN=JSTRT-((JSTRT/100)*100) AA 7
CLKMIN=FLOAT((JSTRT/100)*60+JMIN) AA 8
RETURN AA 9
END AA 10-
AA-1
-------
SUBROUTINE INTERP (TOUT,Y,NO,YO) an
C AB •*•
C PERFORM EXACT INTERPOLATION IN TIME ™ ?
C Atf J
SAVE JB 4
COMMON /GEAR1/ T,HfDUMMY(4),N,IDUMMY(2),JSTART AB fi
DIMENSION YO(NO), Y(NO,1) V? ,
DO 10 1=1,N ?f ^
10 YO(I)=Y(I,1) ~ I
L=MAXO(JSTART+1,2) a? i n
S=(TOUT-T)/H ?f ,10
Sl-1. M U
DO 30 J=2,L J? ^
S1=S1*S ^^ 13
DO 20 1=1,N ^ "
20 YO(I)=YO(I)+S1*Y(I,J) ?! Jc
30 CONTINUE ^ 16
RETURN M 17
END AB 18
AB 19-
AB-1
-------
SUBROUTINE NSBSLV
-------
SUBROUTINE NSCORA (N,IA,JA,A,ZAP,JAWORK,AWORKfC,IR,ICT)
PART OF THE GEAR ROUTINES
SAVE
INTEGER IA{1),JA(1),IAP(1),C(1),IR(1),ICT<1)
REAL A(l),AWORK(l)fJAWORK(l)
DO 10 K=1,N
ICK=C(K)
10 IR(ICK)=K
JMIN=1
DO 30 K=1,N
ICK=C{K)
JMAX=JMIN+IA(ICK+1)-IA(ICK)-1
IF (JMIN.GT.JMAX) GO TO 30
IAINK=IA(ICK)-1
DO 20 J=JMIN,JMAX
IAINK=IAINK+1
JAOUTJ=JA(IAINK)
JAOUTJ=IR(JAOUTJ)
JAWORK(J)=JAOUTJ
20 AWORK(J)=A(IAINK)
30 JMIN=JMAX+1
DO 40 1=1,N
40 ICT(I)=IAP(I)
JMIN=1
DO 60 1=1, N
ICK=C(I)
JMAX=JMIN+1A(ICK+1)-IA(ICK)-1
IF {JMIN.GT.JMAX) GO TO 60
DO 50 J=JMIN,JMAX
JAOUTJ=INT(JAWORK(J))
ICTJ=ICT(JAOUTJ)
A(ICTJ)=AWORK(J)
ICT(JAOUTJ)=ICTJ+1
50 CONTINUE
60 JMIN=JMAX+1
RETURN
END
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
AD
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39-
AD-1
-------
SUBROUTINE NSCORD (N,IA,JA,IAWORK,JAWORK,C,IR,ICT)
C
C PART OF THE GEAR ROUTINES
C
SAVE
INTEGER IA(1),JA(1),IAWORK(1),JAWORK(1),C(1),IR{1),ICT(1)
DO 10 I=lfN
10 ICT(I)=0
IAWORK(1)=1
DO 30 K=1,N
ICK=C(K)
JMIN=IAWORK(K)
JMAX=JMIN+IA(ICK+1)-IA(ICK)-1
IAWORK
-------
SUBROUTINE NSNFAC (N, IA, JA, A, IL, JL, ISL, L, D,
1ER )
C
C PART OF THE GEAR ROUTINES
C
SAVE
INTEGER IA(1),JA(1),IL(1),JL(1),ISL<1)
INTEGER IU(l),JU(l),ISU(l)fIRLU),JRL{l)
REAL A(1),L{1),D(1),U(1),X(1)
REAL LKI
IER=0
DO 10 K=1,N
IRL(K)=IL(K)
10 JRL(K)=0
DO 180 K=1,N
X(K)=0.
11=0
IF (JRL(K) ,EQ.O) GO TO 30
I=JRL(K)
20 I2=JRL(I)
JRL(I)=I1
11=1
X(I)=0.
1=12
IF (I.NE.O) GO TO 20
30 JMIN=ISU(K)
JMAX=JMIN+IU (K+l) -IU (K) -1
IF (JMIN.GT.JMAX) GO TO 50
DO 40 J=JMIN, JMAX
JUJ=JU ( J)
40 X(JUJ)=0.
50 JMIN=IA(K)
JMAX=IA(K+1)-1
DO 60 J=JMIN, JMAX
JAJ=JA(J)
60 X(JAJ)=A(J)
1=11
IF (I.EQ.O) GO TO 100
70 IRLI=IRL(I)
LKI=-X(I)
L(IRLI)=-LKI
JMIN=IU(I)
JMAX=IU(I+1)-1
IF (JMIN.GT.JMAX) GO TO 90
ISUB=ISU(I) -1
DO 80 J=JMIN,JMAX
ISUB=ISUB+1
JUJ=JU(ISUB)
80 X(JUJ)=X(JUJ)+LKI*U(J)
90 I=JRL(I)
IF (I.NE.O) GO TO 70
100 IF (X(K) .EQ.O.) GO TO 190
DK=1./X(K)
D(K)=DK
IF (K.EQ.N) GO TO 180
JMIN=IU(K)
JMAX=IU(K+1}-1
IF (JMIN.GT,. JMAX) GO TO 120
ISUB=ISU(K)-1
DO 110 J=JMIN,JMAX
ISUB=ISUB+1
JUJ=JU(ISUB)
110 U(J)=X(JUJ)*DK
120 CONTINUE
IU, JU, ISU,U,X,IRL,JRL, IAF
AF
AF
AF
AF
AF
AF
AF
AF
rtr
AF
AF
AF
AF
A r
Ar
AF
AF
AF
•* T-l
AF
AF
AF
AF
AF
AF
AF
AF
AF
TV T?
Ar
TV r1
Ac
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
AF
1
2
3
4
5
6
7
8
10
11
12
13
T A
14
15
16
17
18
19
20
21
22
23
24
25
26
O ~T
27
O O
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
AF-1
-------
1=11 AF 65
IF (I.EQ.O) GO TO 170 ap 66
130
Il-JRL(I) AF 6Q
IF (IRL(I) .GE.ILd+1)) GO TO 160 AF 69
ISLB=IRL(I)-IL(I)+ISL(I) AF 70
J=JL(ISLB) AF 71
140 IF (I.GT.JRL(J)) GO TO 150 AF 72
J=JRL(J) AF 73
GO TO 140 AF 74
150 JRL(I)=JRL(J) AP 75
JRL(J)=I AP 7g
160 1=11 ^ ^
IF (I.NE.O) GO TO 130 AF 78
170 ISLK=ISL(K) AP 79
IF (IRL(K) .GE.IL(PC+1» GO TO 180 AF 80
J=JL(ISLK) AF 81
JRL(K)=JRL(J) AF 82
JRL(J)=K AP g3
180 CONTINUE AF 84
RETURN AF fl ,
190 IER=K £
RETURN AF °°
W 88-
AF-2
-------
c
c
c
c
c
c
PART OF THE GEAR ROUTINES
SAVE
INTEGER IA(1),JA(1>,IL(1),JL(1),ISL(1)
INTEGER IU(l)rJU
-------
90 PK=PPK AG 63
PPK=P(PK) . AG I}
IF (V(PPK)-VJ) 90,110,100 AG fic:
100 P(PK)=LSFS ar ll
V(LSFS)=VJ AG °°
P(LSFS)=PPK a7 *'
PPK=LSFS ^ "
LSFS=LSFS+1 ar in
no CONTINUE Vp '!:
G0 T0 70 AG 72
120PI-PU) AG 73
IF (V(PI).NE.K) GO TO 450 AG 74
IF (LASTI.EQ.O) GO TO 130 AG 75
IF (LASTID.NE.LSFS-3) GO TO 130 AG 76
IRLL=IRL(LASTI) AG 77
ISL(K)=IRLL+1 AG 7Q
IF (JL(IRLL).NE.K) ISL(K)=ISL(K)-1 AG 7q
IL(K+1)=IL(K)+LASTID AG ™
IRL(K)=ISL(K) Ar I"
G° T° 16° AG 82
130 ISL(K)=JLPTR+1 ar li
PI=P(1)
PI=P P ) AG 84
v ' ar o t;
VI=V(PI) ' AG 86
140 IF (VI.GT.N) GO TC 150 ar In
JLPTR=JLPTR+1 Ag gg
IF (JLPTR.GT.MAXPL) GO TO 460 ar flQ
JL(JLPTR)=VI fG H
PI=P(PI) AG 9?
VI-V(PI) AG I1
GO TO 140 AG "
150 IRL(K)=ISL(K) f^ \\
IL(K+1)=IL(K)+JLPTR-ISL(K)+1 ar qc
160 P(l)=l
v iUN+I AG 96
V V J. / INTX a_ Q_
LSFS=2 AG 98
JMIN=IRA(K) f3 II
JMAX»IA(K+1)-1 ££ ^o
IF (JMIN.GT.JMAX) GO TO 200 Ar ini
DO 190 J=JMIN,JMAX ar
T7TT-»/-r\ ' "(a
VJ=JA(J)
PPK=1 AG
170PK=PPK AG
PPK=P(PK) AG 106
IF (V(PPK)-VJ) 170,410,180 ar
180 P(PK)=LSFS AG
V(LSFS)=VJ AG
P(LSFS)=PPK AG
190 LSFS=LSFS+1 ar
200 LASTI = 0 AG
T=K
210 I-JRL(I) AG
IF (I.EQ.O) GO TO 260 a7
PPK=I Aj:
JMIN=IRU(I) A^
JMAX=ISU(I)+IU(I+1)-IU{I)-1 ' ar ip
IF (LASTI.GT.I) GO TO 220 ar
LAST 1=1 ^
LASTID=JMAX-JMIN ^
IF (JU(JMIN).NE.K) LASTID=LASTID+1 Ar
220 IF (JMIN.GT.JMAX) GO TO 210 a7
DO 250 J=JMIN,JMAX ?P
VJ=JU(J)
230 PK=PPK «
AG-2
-------
PPK=P(PK)
IF (V(PPK)-VJ) 230,250,240 AG,
240 P(PK)=LSFS ?-
V(LSFS)=VJ AG
P(LSFS)=PPK AG
PPK=LSFS ~~
250 LSFS=LSFS+1 A
GO TO 210
260 PI-P(l) AG 1?«
IF (V(PI).NE.K) GO TO 420 ar
IF (LASTI.EQ.O) GO TO 270 ac
IF (LASTID.NE.LSFS-3) GO TO 270 ar
IRUL=IRU(LASTI) AP
ISU(K)=IRUL+1 Ar
IF (JO(IROL).NE.K) ISO(K)=ISU(K)-1 ar
IU(K+1)=IU(K)+LASTID IT
IRU(K)=ISU(K) AG
GO TO 300 143
270 ISU(K)=JUPTR+1 A^ l\\
PI=P(1) 145
pl=p(pl) AG 146
VI-V(PI) AG W
280 IF (VI.GT.N) GO TO 290 ar
JUPTR=JUPTR-l-l ' AG
IF (JUPTR.GT.MAXPU) GO TO 430 ar
JU(JUPTR)=VI AG
PI=P(PI)
VI=V(PI) AG 153
GO TO 280 AG 154
290 IRU(K)=ISU(K) AG ]l5
IU(K+1)=IU(K)+JUPTR-ISU(K)+1 AP , ?!
300 I=K AG 15_~
310 I1=JRL(I) AG
CEND=ISL(I)+IL(I+1)-IL(I) ar
IF (IRL(I).GE.CEND) GO TO 320 ar
IRLI=IRL(I) AG
J=JL(IRLI) AG
JRL(I)=JRL(J) AG
JRL(J)=I AG
320 i=n AG 165
IF (I.EQ.O) GO TO 330 A?
GO TO 310
330 I=K AG 169
340 I1=JRU(I) AG
REND=ISO(I)+IU{I + 1)-IU(I) a^
IF (IRO(I) .GE.REND) GO TO 350 ^
IRUI=IRU(I) AG 173
J=JU(IRUI) AG 174
JRU(I)=JRU(J) AG 175
JRU(J)=I AG 176
350 1=11 AG 177
IF (I.EQ.O) GO TO 360 AG, }~L*
IRU(I)=IRU(I)+1 AG ^79
GO TO 340 AG 18°
360 I=IRAC(K) AG 181
IF (I.EQ.O) GO TO 390 AG, n18?
370 I1=JRA(I) AG 183
AG 184
IF (IRA(I).GE.IA(I+1)) GO TO 380
IRAI = IRA(I)
IF (JA(IRAI).GT.I) GO TO 380
JAIRAI=JA(IRAI)
JRA(I)=IRAC(JAIRAI) AG
AG-3
-------
IRAC(JAIRAI)=I AG 191
380 1=11 AG 192
IF (I.NE.O) GO TO 370 AG 193
390 CONTINUE AG 194
ISL(N)=JLPTR AG 195
ISU(N)=JUPTR AG 196
RETURN AG 197
400 CALL YSMER ('ROW'(,K, ' OF A IS NULL') AG 198
GO TO 470 AG 199
410 CALL YSMER ('ROW'(,K, ' HAS DUPLICATE ENTRY') AG 200
GO TO 470 AG 201
420 CALL YSMER ('ROW',K,' HAS A NULL PIVOT') AG 202
GO TO 470 AG 203
430 CALL YSMER ('ROW',,K, ' EXCEEDS JU STORAGE') AG 204
GO TO 470 AG 205
440 CALL YSMER ('COL',K, ' HAS DUPLICATE ENTRY') AG 206
GO TO 470 AG 207
450 CALL YSMER ('COL',,K,' HAS A NULL PIVOT') AG 208
GO TO 470 AG 209
460 CALL YSMER ('COL',,K, ' EXCEEDS JL STORAGE') AG 210
470 IER-1 AG 211
RETURN AG 212
END AG 213-
AG-4
-------
SUBROUTINE OZMX (C,TLL,TOUT,NO) au ,
C ^^ ^
AH 9
C CALCULATE THE MAXIMUM 1 HR AVERAGE VALUE USING A RUNNING AVERAGE AH 3
SAVE JJ} *
51,5), OZ(61,5), OZA{5), TL(5), NT(5) AH 6
RETURN
AH 7
AH 8
COMMON /CALC/ NR, KR <2ob;i2J ,~A(200^ S (200) , R (200) , ITYPE (200) , IA (60) A^ 10
™K«,™ / ,JA(800),DILUT,TEMP,ERR,START,STOPP,TPRNT,TSTEP,ZENIAH 11
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH<20),iNOX(2;, AH 12
1 FIN«C(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN, AH 13
2 XNAL,NOZ,FENX(2),CR(61),NI,JOZ{5) AH 14
AH 1 ^
COMMON /CALCHR/ SPECIS(61) V£ , JL
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61) AH 1SR
CHARACTERM SPECIS, HCSPEC, REACT, PLSP £j| ^
NQ=JSTART ?? "D
IF (T.NE.START) GO TO 20 VC ^
DO 10 1=1,NOZ JJ ^
KOZ=JOZ(I) ™J in
RUN(1,I)=C(KOZ,1) A* on
NT(I)=1 AH 20
TL(I)=START+1. J2 oo
OZM(I)=0. ^ 22
OZA(I)=0. A[J 2^
10 CONTINUE Mi 24
TLL=TL(1) ™ 25
AH 26
20 DO 130 JJ=1,NOZ ^J 27
KOZ=JOZ(JJ) VM oo
30 DO 40 1=1,61 AH 29
RR=(TL(JJ)+FLOAT(I-1)-T)/H ™ ??
IF (RR.GT.O.) GO TO 50
AH "^ 9
IF (TL(JJ)+FLOAT(I--1).GT. STOPP) GO TO 50 AH „
OZ(I,JJ)=C(KOZ,1) At; ~
RH=1. AH 34
DO 40 J=1,NQ AH 35
RH=RH*RR AH 36
40 OZ(I,JJ)=OZ(I,JJ)+RH*C(KOZ,J+1) ' *„ ^
1=61 ^^ Ja
50 1=1-1 AH 39
TL(JJ)=TL(JJ)+FLOAT(I) ^ J?
DO 90 J=1,I AH 41
IF (NT(JJ) .GT.60) GO TO 70 AJj ^
NTT=NT(JJ) AH 4J
RUN(NTT+1,JJ)=OZ(J,JJ) A" ^
NT(JJ)=NT(JJ)+1 Af; 45
IF (NT(JJ).LT.61) GO TO 90 ™ ^
SIX(JJ)=0. AH 47
S2(JJ)=RUN(60,JJ) AJJ 48
DO 60 K=l,29 AH 49
SIX(JJ)=SIX(JJ)+RUN(2*K+1,JJ) ™ 1Q,
60 S2(JJ)=S2(JJ)+RUN(2*K,JJ) A" „
70 sv=SIX(JjrSIX(JJ)+4'*S2(JJ)+RUN(1'JJ)+^ A« "
SIX(JJ)=S2(JJ)-RUN(2,JJ) AJJ ^
S2(JJ)=SV+OZ(J,JJ) A|J "
RUN(61,JJ)=OZ(J,JJ) A, 56
DO 80 K=l,60 AH 57
80 RUN(K,JJ)=RUN(K+1,JJ) AJJ 58
IF (OZA(JJ).GT.OZM(JJ)) OZM(JJ)=OZA(JJ) ^ ^
AH-1
-------
IF (OZA(JJ).EQ.OZM(JJ)) TM
-------
SUBROUTINE SAVIT (T,C)
SAVE INTERMEDIATE CONCENTRATIONS FOR PLOTTING PURPOSES
SAVE
COMMON /FRPLOT/ SAVCON(80,5),SAVTIM(SO),NT,INOW
COMMON /SPEC/ NSfCARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
2 XNAL,NOZ,FENX{2),CR(61), NI,KOZ(5)
COMMON /SPECHR/ HCSPEC(20), PLSP(5)f REACT(61)
CHARACTER*4 HCSPEC, REACT, PLSP
DIMENSION C(80)
DATA NFRST/1/
IF (NFRST.NE.l.AND.T.EQ.TOLD) RETURN
IF (NT.EQ.O) NT=1
NFRST=2
TOLD=T
IF (NT.GT.80) RETURN
IF (T.LT.SAVTIM(NT)) RETURN
SAVTIM(NT)=T
DO 10 II=lfNOZ
I=KOZ(II)
SAVCON(NT,II)=C(I)
10 CONTINUE
NT=NT+1
RETURN
END
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
AI
1
2
3
4
5
6
7
• 8
9
9A
9B
9C
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28-
AI-1
-------
SUBROUTINE SORDER (N,IA,JA,P,Q,MAX,V,L,IER) AJ 1
C AJ 2
C PART OF THE GEAR ROUTINES AJ 3
C AJ 4
SAVE AJ 5
INTEGER IA{1),JA(1),P(1),Q(1),V(1),L(1) AJ 6
INTEGER S,SFS,PI,PJ,VI,VJ,VK,QVK,DTHR,DMIN AJ 7
IER=0 AJ 8
DO 10 S=1,MAX AJ 9
10 L(S)=S+1 AJ 10
SFS=1 AJ 11
L(MAX)=0 AJ 12
DO 20 K=1,N AJ 13
P(K)=K AJ 14
Q(K)-K AJ 15
V(K)=1 AJ 16
20 L(K)=0 AJ 17
SFS=SFS+N AJ 18
DO 100 K=1,N AJ 19
JMIN=IA(K) AJ 20
JMAX=IA(K+1)-1 AJ 21
IF(JMIN.GT.JMAX+1) GO TO 290 AJ 22
KDIAG=0 AJ 23
DO 90 J=JMIN,\JMAX AJ 24
VJ=JA(J) AJ 25
IF (VJ.NE.K) GO TO 30 AJ 26
KDIAG=1 AJ 27
GO TO 90 AJ 28
30 LLK=K AJ 29
40 LK=LLK AJ 30
LLK=L(LK) AJ 31
IF (LLK.EQ.O) GO TO 50 AJ 32
IF (V(LLK)-VJ) 40,60,50 AJ 33
50 LLK=SFS AJ 34
IF (LLK.EQ.O) GO TO 300 AJ 35
SFS=L(SFS) AJ 36
V(K)=V(K)+1 AJ 37
V(LLK)=VJ AJ 38
L(LLK)=L(LK) AJ 39
L(LK)=LLK AJ 40
60 LLK=VJ AJ 41
70 LK=LLK AJ 42
LLK=L(LK) AJ 43
IF {LLK.EQ.O) GO TO 80 AJ 44
IF (V(LLK)-K) 70,90,80 AJ 45
80 LLK=SFS AJ 46
IF (LLK.EQ.O) GO TO 300 AJ 47
SFS=L(SFS) AJ 48
V(VJ)=V(VJ)+1 AJ 49
V(LLK)=K AJ 50
L(LLK)=L(LK) AJ 51
L(LK)=LLK AJ 52
90 CONTINUE AJ 53
IF (KDIAG.EQ.O) GO TO 320 AJ 54
100 CONTINUE AJ 55
J=0
AJ 56
DTHR=0 AJ 57
DMIN=N AJ 58
1=0 AJ 59
110 I=I+! AJ 60
IF (I.GT.N) GO TO 280 AJ 61
JMIN=MAXO(J+1,I) AJ 62
IF (JMIN.GT.N) GO TO 140 AJ 63
120 DO 130 J=JMIN,N AJ 64
AJ-1
-------
VI=P(J> AT »
IF (V(VI).LE.DTHR) GO TO 150 ?i "
IF (V(VI).LT.DMIN) DMIN=V(VI) ar c?
130 CONTINUE b '
140 DTHR=DMIN AJ 68
DMIN=N AJ 69
JMIN-I AJ 70
GO TO 120
71
150 PJ=P(I) AJ 72
P(J)=PJ AJ 73
Q(PJ)=J ^J 74
PI=VI AJ 75
P(I)=PI AJ 76
Q(PI)=I ™ 77
LI-VI AJ 78
160 LI=L(LI) AJ 79
IF (LI.EQ.O) GO TO 210 AlJ !?
VK=V(LI) Avl °l
LLK=VK AX f?
LJ=VI AJ 83
170 LJ=L(LJ) AJ 84
IF (LJ.EQ.O) GO TO 200 AlJ ?^
VJ=V(LJ) AJ S6
IF- (VJ.EQ.VK) GO TO 170 A^ H
180 LK=LLK AJ 88
LLK=L(LK) A^ 89
IF (LLK.EQ.O) GO TO 190 *7 *?
IF (V(LLK)-VJ) 180,, 170, 190 ^T QO
190 LLK=SFS AJ y^
IF (LLK.EQ.O) GO TO 310 A^ ^
SFS=L(SFS) All 94
V(VK)=V(VK)+1 Avl 9^
V(LLK)=VJ AJ 96
L(LLK)=L(LK) . AJ 97
L(LK)=LLK Av? 98
GO TO 170 AJ "
200 IF (V(VK).GT.V(VI)) GO TO 160 ^ |°?
1=1+1 AJ 101
QVK=Q(VK) A^ ]-°2
PI-P(I) AJ 103
P(QVK)=PI AJ 104
Q(PI)=QVK AJ 105
P(I)=VK AJ 106
Q(VK)=I AJ 107
GO TO 160 AJ 108
210 LI=VI AJ 109
220 IF (L(LI).EQ.O) GO TO 270 ^
LI=L(LI) A^
VK=V(LI) AJ
LLK=VK AJ
QVK=MINO(Q(VK),I) A^
230 LK=LLK AJ
LLK=L(LK) AJ
IF (LLK.EQ.O) GO TO 240 A^
VJ=V(LLK) AJ
IF (Q(VJ).GT.QVK) GO TO 230 A^
V(VK)=V(VK)-1 AJ
L(LK)=L(LLK) AJ
L(LLK)=SFS AJ 122
SFS=LLK AJ 123
LLK=LK AJ 124
GO TO 230 AJ 125
240 IF (Q(VK).LE.I) GO TO 260 AJ 126
IF (V(VK).LE.DTHR) GO TO 250 ^ ^27
Ao 128
AJ-2
-------
IF ((DTHR.LT.V(VK)).AND.(V(VK).LT.DMIN)) DMIN=V(VK)
GO TO 220
250 J=MINO(Q(VK)-1, J)
DTHR=V(VK)
GO TO 220
260 L(LK)=SFS
SFS=L(VK)
GO TO 220
270 L(LI)=SFS
SFS=L(VI)
GO TO 110
280 RETURN
290 CALL YSMER {'ROW',K,' OF A IS NULL')
GO TO 330
300 CALL YSMER ('ROW',K,' EXCEEDS STORAGE')
GO TO 330
310 CALL YSMER ('VERTEX',VI,' EXCEEDS STORAGE')
GO TO 330
320 CALL YSMER ('COLUMNAR,'.. DIAGONAL MISSING')
330 IER=1
RETURN
END
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
AJ
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150-
AJ-3
-------
SUBROUTINE YSMER (A,K,A1) ^ x
\*
C WRITE ERROR MESSAGES ^ ?
C AK d
SAVE ^ ^
C INTEGER AfAl{5) av e
CHARACTER*6 A av L
CHARACTER*4 Al{5) AK fiR
COMMON /INOUT/ INP,LOUT,ITAPE,IALN,IALL,INHHrIOZC AK 7
WRITE (LOUT,10) A,K,(Al(II),11=1,5) AK fl
RETURN £ J
c AK 10
10 FORMAT (1X,A4,I6,5A4) ^ }]
END AK 13-
AK-1
-------
FUNCTION CIRC (TI,XI,YI) AL 1
C AL 2
C PERFORM INTERPOLATION USING FOUR POINTS AL 3
C AL 4
SAVE AL 5
DIMENSION XI(3), YI{3) AL 6
DX=XI{3)-XI(1) AL 7
DY=YI(3)-YI{1) AL 8
X=(XI{2)-XI(1))/DX AL 9
Y=(YI(2)-YI(1))/DY AL 10
T=(TI-XI{1))/DX AL 11
IF (X.EQ.Y) GO TO 20 AL 12
B=((X*X+Y*Y)*0.5-X)/(Y-X) AL 13
TT=SQRT(B*B+2.*T*(1.-B)-T*T) AL 14
CX=B+TT AL 15
IF (X.GT.Y) CX=B-TT AL 16
IF (CX.LT.O..OR.CX.GT.l.) GO TO 20 AL 17
10 CIRC=CX*DY+YI(1) AL 18
RETURN AL 19
20 CX=T*Y/X AL 20
IF (T.GT.X) CX=(T"X)M1.-Y)/U.-X)+Y AL 21
GO TO 10 AL 22
END
AL 23-
AL-1
-------
SUBROUTINE SPLOT
PLOTS SPECIES CONCENTRATIONS AS A FUNCTION OF TIME
SAVE
COMMON /TITL/ ITTL(36)
COMMON /INOUT/ IN, IOUT, ITAPEr IALNf IALL, INHH, IOZC
COMMON /CALC/ NR, KR (200f 12) , A (200) , S (200) , R (200) , ITYPE (200) ,
1 IA{ 60 ),JA (800 ),DILUT, TEMP, ERR, START, STOPP,TPRNT,
2 TSTEP,ZENI
COMMON /SUNLIT/ Z ( 10) , RTCON (10) , LAM1, INC, SLA, SLO, TZ, IY, IM ID
COMMON /SPEC/
COMMON /HOUR/
ISTRT,ISTOP,IINC,IEND,SPECIE,MAXZ,ITIME(24),
XZ(24),KKK(24),JSTRT,JSTOP,PSPEC,MNLM,MXLM,MAXL,
MAXJ
NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN
XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
OZM(5),NGO,TM,DUMMM(5)
COMMON /FRPLOT/ SAVCON(80,5),SAVTIM(80),NT1,INOW
COMMON /PLTND/ JB.AR, JSYMB, CVERT (9) , TVERT (52, 2)
COMMON /NEED1/ JBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO,1103
1 IIH20,JPLUS
DIMENSION JGRID(lOl), JSAV(lOl)
C
COMMON /CALCHR/ SPECIS(61)
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER*! JBAR, JSYMB
CHARACTER*2 ITTL
CHARACTERM SPECIS, HCSPEC, REACT, PLSP
CHARACTER*4 JGRID, CVERT, TVERT
CHARACTER*4 JBLANK,MBLANK,IIHC,IINX,IICO,IIN02,IINO 1103
1 IIH20,JPLUS
C
DIMENSION TPRINT(ll),TV1(10)
DATA MAXHC/101/,MAXNOX/50/,TGRID/100./,CGRID/50./
\*
NT=NT1-1
TCI=FLOAT(JSTRT)
DO 100 L=1,NOZ
IF (OZM(L).LE.O.) GO TO 100
C
C SET NORMALIZATION FACTORS AND VERTICAL LABELS
C
CLOW=0.
TLOW=0.
CH=OZM(L)*1.1
CH1=ALOG10(CH)
IAMEG=IFIX(CH1)
IF (CH1.LT.O.) IAMEG=IAMEG-1
CHIGH=CH/(10.**IAMEG)
REM=CHIGH-FLOAT(IFIX(CHIGH))
CHIGH=CH+(1.-REM)*(10.**IAMEG)
CSPAN=CGRID/CHIGH
DO 10 1=1,10
TV1(I)=(FLOAT(M) *.].) *CHIGH
10 CONTINUE
C
C SET HORIZONTAL LABELS
C
20 THIGH=STOPP
30 TSPAN=TGRID/THIGH
DO 40 J=l,ll
TPRINT(J)=(FLOAT(J-l)/10.)*THIGH+.5
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
1
2
3
4
5
6
7
8
9
9A
10
11
11A
12
13
14
15
16
17
18
19
20
21
21A
21B
21C
21D
21E
21F
21G
21H
211
21J
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
AM-1
-------
TPRINT (J) ==CLOCK {TCI, IFIX (TPRINT {J) ) )
40 CONTINUE
C
C CLEAR GRID
C
MAXHC1=MAXHC-1
DO 50 J=1,MAXHC
JSAV(J)=0
50 CONTINUE
C
IF (NT.LT.l) NT=1
DO 60 J=1,NT
KHC=IFIX((SAVTIM(J)-TLOW)*TSPAN+1.5)
KNOX=IFIX((SAVCON{J,L)-CLOW)*CSPAN-0.5)
KNOX=MAXNOX-KNOX
IF (KNOX.LT.l) GO TO 60
IF (KNOX.GT.MAXNOX) GO TO 60
IF (KHC.LT.l) GO TO 60
IF (KHC.GT.MAXHC1) GO TO 60
IF (KHC.LT.2) GO TO 60
JSAV(KHC)==KNOX
60 CONTINUE
C
WRITE (IOUT,110) TVERT(1, 1) , TV1 (1)
DO 90 K=2,MAXNOX
M=MOD((K-1),5)
DO 70 J=2,MAXHC1
JGRID(J)=JBLANK
IF (JSAV(J).EQ.K) JGRID(J)=JSYMB
70 CONTINUE
IF (M.NE.O) GO TO 80
JGRID(1)=JPLUS
JGRID{101)=JPLUS
WRITE (IOUT,130) TVERT(K,1),TV1(I),(JGRID(J),J=l,MAXHC)
GO TO 90
80 JGRID(1)=JBAR
JGRID(101)=JBAR
WRITE (IOUT,140) TVERT(K,1),(JGRID(J),J=l,MAXHC)
90 CONTINUE
WRITE (IOUT,150) CLOW
WRITE (IOUT,170) TPRINT
WRITE (IOUT,160) (ITTL(I),1=1,36)
WRITE (IOUT,180) PLSP(L)
100 CONTINUE
RETURN
FORMAT STATEMENTS
-+)/18Xr101A1/18X,101A1)
110 FORMAT (1H1////9X,A4,F5.3,1H+,10(10H-
120 FORMAT (1H1//////18X,1H+,10(10H
130 FORMAT (9X,A4,F5.3,101A1)
140 FORMAT (9X,A4,5X,101A1)
150 FORMAT (13X, F5 .3, 1H+, 10 (10H +) )
160 FORMAT (46X,36A2)
170 FORMAT (F21.0,10F10.0/63X,14H TIME (LOT) //)
180 FORMAT (1HO/45X,A4,36H CONCENTRATION AS A FUNCTION OF TIME)
END
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
AM
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112-
AM-2
-------
SUBROUTINE CURV1
-------
c
FOR YP AND PERFORM FORWARD ELIMINATION AN 65
DELS=SIGMAP*DELX1 AN 66
IF (ABS(DELS).GE.EXPMAX) GO TO 110 AN 67
EXPS=EXP(DELS) AN 68
SINHS=0.5*(EXPS-1,/EXPS) AN 69
SINHIN=1./(DELX1*SINHS) AN 70
DIAG1=SINHIN*(DELS*0.5*(EXPS+1./EXPS)-SINHS) AN 71
DIAGIN=1./DIAG1 AN 72
YP(1)=DIAGIN*(DX1-SLPP1) AN 73
SPDIAG=SINHIN*(SINHS-DELS) AN 74
TEMP(1)=DIAGIN*SPDIAG AN 75
IF (N.EQ.2) GO TO 30 AN 76
DO 20 1=2,NM1 AN 77
DELX2=X(I+1)-X(I) AN 78
IF (ABS(DELX2)/X(J+1).LT.0.02) GO TO 110 AN 79
DX2=(Y(I+1)-Y(I))/DELX2 AN 80
DELS=SIGMAP*DELX2 AN 81
IF (ABS(DELS).GE.EXPMAX) GO TO 110 AN 82
EXPS=EXP(DELS) AN 83
SINHS=.5*(EXPS-1./EXPS) AN 84
SINHIN-1./(DELX2*SINHS) AN 85
DIAG2=SINHIN*(DELS*{.5*(EXPS+l./EXPS))-SINKS) AN 86
DIAGIN=1./(DIAG1+DIAG2-SPDIAG*TEMP(I-1)) AN 87
YP(I)=DIAGIN*(DX2-DX1-SPDIAG*YP{!-!)) AN 88
SPDIAG=SINHIN*(SINHS-DELS) AN 89
TEMP(I)=DIAGIN*SPDIAG AN 90
DX1=DX2 AN 91
DIAG1=DIAG2 AN 92
20 CONTINUE AN 93
30 DIAGIN=1./(DIAG1-SPDIAG*TEMP(NM1)) AN 94
YP(N)=DIAGIN*(SLPPN-DX2-SPDIAG*YP(NM1)) AN 95
AN 96
C *** PERFORM BACK SUBSTITUTION AN 97
DO 40 1=2,N AN 98
IBAK=NP1-I AN 99
YP(IBAK)=YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) AN 100
40 CONTINUE AN 101
IF (SIGMA.GT.O.) RETURN AN 102
IF (N.EQ.3) RETURN AN 103
IF (NCYC.GT.15) RETURN AN 104
IF (NCYC.GT.O) GO TO 50 AN 105
XTEST=(X(3)+X(2))/2. AN 106
YCORD=(Y(3)+Y(2))/2. AN 107
FACT=SQRT(ABS(SIGMA)) AN 108
YTEST=(YCORD*FACT+CIRC(XTEST,X(1),Y(1))+CIRC(XTEST,X(2),Y(2)))/(2.AN 109
1+FACT) . AN 110
ITHH=1 . AN 111
DY2=CURV2(XTEST,N,X,Y,YP,SIGMA,ITHH)-YTEST AN 112
DSAV=DY2 AN 113
SN— 1. AN 114
IF (DY2.GT.O.) SN=1. AN 115
FACT=0.3*(SN+2.) AN 116
DY2=0. AN 117
IT-1 AN 118
50 NCYC=NCYC+1 AN 119
DY1=DY2 AN 12Q
DY2=CURV2(XTEST,N,X,Y,YP,SIGMA,IT)-YTEST AN 121
IF (NCYC.GT.15) RETURN AN 122
IF (NCYC.GT.13.AND.NCHG.LT.2) GO TO 80 AN 123
IF
-------
70 SLPP1=SLPP1*(1.+SN*FACT) ,„
» T° 10 £
AN 13 1
80 IF (DY2/DSAV.LT.0.2) GO TO 70 AN
SLPP1=SLPPX
NCYC=15
GO TO 10
90 IF (N.EQ.2) GO TO 100 ^N 136
AN 137
C *** IF NO DERIVATIVES ARE GIVEN USE SECOND ORDER POLYNOMIAL AN 138
C INTERPOLATION ON INPUT DATA FOR VALUES AT ENDPOINTS. AN 139
SLPP1-(Y(2)-Y(1))/(X{2)-X(1)> AN 140
DELN=X(N)-X(NM1) ™ ™
DELNMl=X(NMl)-X(N-2) AN ,^
DELNN=X(N)-X(N-2) ^ ™
IF (ABS(DELN)/X(N) .LT.0.02) GO TO 110 AN 144
IF (ABS(DELN)/X(N) .LT.0.02) GO TO 110 AN 145
IF (ABS(DELNM1)/X(NM1) .LT.0.02) GO TO 110 AN 146
IF (ABS(DELNN)XX(N) .LT.0.02) GO TO 110 AN 147
C1=(DELNN+DELN)/DELNN/DELN m
C2— DELNN/DELN/DELNM1 CJ,
C3=DELN/DELNN/DELNM1 a^
SLPPN=C3 * Y (N-2 ) +C2 - Y (NM1 ) +C1 *Y (N) AN
DX2=X(3)-X{2) . ^
DX31=X(3)-X(1) ™
IF (ABS(DX2)/X(3). LT.0.02) GO TO 110 AN 154
IF (ABS(DX31)/X(3) .LT.0.02) GOTO 110 AN 155
C1=-{DX31+DELX1)/DX31/DELX1
C2=DX31/DELX1/DX2
C3=-DELX1/DX31/DX2
SLPPX=Cl*Y(l)-»-C2*Y(2)+C3*Y(3) AN 159
IF (Y{2) .GT.Y(l)) SLPPX-AMAX1 <0. , SLPPX) AN 160
FACT2=SQRT (ABS ( SIGMA)) AN ^
SLPPX=(SLPPX+FACT2*SLPP1)/(1.+FACT2) AN 162
SLPP1=SLPPX
IF (Y(N).GT.Y(NMl)) SLPPN=AMAX1 (0 . , SLPPN) AN 164
SLPNL=(Y(N)-Y(NM1))/DELN AN ,„
SLPPN=(SLPPN+SLPNL*FACT2)/(1.+FACT2) AN 166
SLPPN- (SLPPN-SLPNL*SIGMA) /{I. -SIGMA) AN 1 fil
G0 T0 10 AM \CQ
c AN 168
AN 169
C *** IF ONLY TWO POINTS AND NO DERIVATIVES ARE GIVEN, USE AN 170
C STRAIGHT LINE FOR CURVE AN 171
100 YP(1)=0.
YP(2)=0.
RETURN . AN 175
110 .SIGMA=-50. ™. L'l
RETURN ^
END AN 178-
AN-3
-------
FUNCTION CURV2 (T,N,X,Y,YP,SIGMA,IT) AO 1
c AO 2
C THIS FUNCTION INTERPOLATES A CURVE AT A GIVEN POINT AO 3
C USING A SPLINE UNDER TENSION. THE SUBROUTINE CURV1 SHOULD AO 4
C BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY AO 5
C PARAMETERS. AO 6
C AO 7
C ON INPUT— AO 8
C T = A REAL VALUE TO BE MAPPED ONTO THE AO 9
C INTERPOLATING CURVE. AO 10
C N = THE NUMBER OF POINTS WHICH WERE INTERPOLATED AO 11
C TO DETERMINE THE CURVE, AO 12
C X,Y = ARRAYS CONTAINING THE ORDINATES AND ABCISSAS AO 13
C OF THE INTERPOLATED POINTS, AO 14
C YP = AN ARRAY WITH VALUES PROPORTIONAL TO THE SECOND AO 15
C DERIVATIVE OF THE CURVE AT THE NODES AO 16
C SIGMA = THE TENSION FACTOR (ITS SIGN IS IGNORED) AO 17
C IT IS AN INTEGER SWITCH. IF IT IS NOT 1 THIS INDICATES AO 18
C THAT THE FUNCTION HAS BEEN CALLED PREVIOUSLY (WITH N,X, AO 19
C Y,YP, AND SIGMA UNALTERED) AND THAT THIS VALUE OF T AO 20
C EXCEEDS THE PREVIOUS VALUE. WITH SUCH INFORMATION THE AO 21
C FUNCTION IS ABLE TO PERFORM THE INTERPOLATION MUCH MORE AO 22
C RAPIDLY. IF A USER SEEKS TO INTERPOLATE AT A SEQUENCE AO 23
C OF POINTS, EFFICIENCY IS GAINED BY ORDERING THE VALUES AO 24
C INCREASING AND SETTING IT TO THE INDEX OF THE CALL. AO 25
C IF IT IS 1 THE SEARCH FOR THE INTERVAL (X (K) , X (K+l) ) AO 26
C CONTAINING T STARTS WITH K=l. AO 27
C THE PARAMETERS N,X,Y,YP AND SIGMA SHOULD BE INPUT AO 28
C UNALTERED FROM THE OUTPUT OF CURV1. AO 29
C AO 30
C ON OUTPUT— AO 31
C CURV2 = THE INTERPOLATED VALUE. FOR T LESS THAN AO 32
C X(l) CURV2 = Y(l). FOR T GREATER THAN X(N) CURV2 = Y(N). AO 33
C AO 34
C NONE OF THE INPUT PARAMETERS ARE ALTERED. AO 35
C AO 36
C *** AK CLINE/NCAR, COMM. ACM 17,4(APR.1974), 221 AO 37
C AO 38
SAVE . AO 39
DIMENSION X(N), Y(N), YP(N) AO 40
COMMON /EXPVAL/ EXPMAX AO 41
C AO 42
S=X(N)-X(1) AO 43
IT=IABS(IT) AO 44
0
C *** DENORMALIZE SIGMA AO 46
SIGMAP=ABS(SIGMA)* FLOAT(N-l)/S AO 47
C
4 g
C *** IF IT.NE. 1 START SEARCH WHERE PREVIOUSLY TERMINATED, AO 49
C OTHERWISE START SEARCH FROM BEGINNING AO 50
IF (IT.EQ.l) 11=2 AO 51
C AO 52
C *** SEARCH FOR INTERVAL AO 53
10 DO 20 1=11, N AO 54
IF (X(I)-T) 20,20,30 AO 55
20 CONTINUE A0 56
I=N AO 57
AO 5 8
C *** CHECK TO INSURE CORRECT INTERVAL AO 59
30 IF (X(I-l) .LE.T.OR.T.LE.X(l)) GO TO 40 AO 60
C AO 61
C *** RESTART SEARCH AND RESET II AO 62
C (INPUT (IT( WAS INCORRECT) AO 63
11=2 AO 64
AO-1
-------
AND.EXPTST
AND.EXPTST
.LT.O
.GT.O
LT.O
GT.O
EXPTST=-EXPMAX
EXPTST=EXPMAX
EXPTST=-EXPMAX
EXPTST=EXPMAX
GO TO 10
*** SET UP AND PERFORM INTERPOLATION
40 IF (SIGMA. LE. (-49.)) GO TO 50
DEL1=T-X(I-1)
DEL2=X(I)-T
DELS=X(I)-X(I-1)
EXPTST=SIGMAP*DEL1
IF (ABS(EXPTST) .GT.EXPMAX. AND.EXPTST
IF (ABS(EXPTST) .GT.EXPMAX. AND.EXPTST
EXPS1=EXP(EXPTST)
SINHD1-.5MEXPS1-1./EXPS1)
EXPTST=SIGMAP*DEL2
IF (ABS(EXPTST) .GT.EXPMAX
IF (ABS(EXPTST) .GT.EXPMAX,
EXPS=EXP (EXPTST)
SINHD2=.5* (EXPS-l./EXPS)
ALN1=ALOG(ABS(EXPS1) )
ALN2=ALOG(ABS(EXPS) )
IF (ABS(ALN1+ALN2) . GT.EXPMAX. AND .EXPS . GT. 1
IF (ABS(ALN1+ALN2) .GT. EXPMAX. AND .EXPS . LT . 1
1 EXPS=EXP (-EXPMAX)
IF (ABS (ALN1+ALN2) .LT. EXPMAX) EXPS=EXPS1 *EXPS
SINHS=. 5* (EXPS-l./EXPS)
CURV2=(YP(1)*SINHD1+YP(I-1)*SINHD2)/SINHS+((Y(I)-YP(I))*DEL1+(Y(I-
ll)-YP(I-l) )*DEL2)/DELS
IF ( (ABS (Y(I) -CURV2 ) +ABS ( Y ( 1-1 ) -CURV2) ) . GT . 1 . 001 * (ABS ( Y ( I ) -Y ( 1-1 ) )
1)) IT=-IT
11 = 1
RETURN
50 IF (I.EQ.l) 1=2
IF (ABS(X(I)-X(I-1))/X(I) .LT.0.02) 1=1+1
IF (I.GT.N) I=N
E-10)
E-10)
EXPS=EXP(EXPMAX)
IT=1
RETURN
END
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
-AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
AO
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101-
AO-2
-------
SUBROUTINE RLINE (KS1,JS)
SAVE
COMMON /NEED/ HC,XN,NL,OZP(20),OZN(11,11,5),MR,LS,HCS,XNS
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTO,TSTRTfDTIM,Zl,Z2fDCON,EHC,EXN,
COMMON /HOUR/
COMMON /SPEC/
FLST,TLST
OZM(5),NGO,TM,DUMMM(5)
NS,GARB(20),RCTY(20),XNF(2),IH(20),INOX(2),
L FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN,
I XNAL,NOZ,FENX(2),C(61),NI,KOZ(5)
COMMON /INOUT/ IN,IOUT,ITAPE,IALN,IALL,INHH,IOZC
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT(61)
CHARACTER* 4 HCSPEC,REACT,PLSP
IF (KS1.GE.121) RETURN
IF (INFO.EQ.O) WRITE (IOUT,365) (PLSP(I),1=1,NOZ)
IF (INFO.LT.O) WRITE (IOUT,370) (PLSP(I),1=1,NOZ)
IF (KS1.GT.O) IBEG=KS1+1
IF (JS.LE.O) IBEG=1
INX=1
DO 20 K=IBEG,121
I=MOD(K,11)
IF (I.EQ.O) 1=11
HCC = FLOAT(J-l)*.l * HC
XNN = FLOAT(1-1)*.l * XN
CALL SIM (HCC, XNN,, OZN (I, J, 1) , INX)
DO 10 L=2,5
OZN(I,J,L)=OZM(L)
10 CONTINUE
20 CONTINUE
RETURN
365 FORMAT (1H1,//,14X,36HTHE FOLLOWING SIMULATIONS WERE DONE
1,6X,4HNMOC,11X,3HNOX,12X,5HRATIO,10X,5(A4,11X))
370 FORMAT (1H1,//,14X,36HTHE FOLLOWING SIMULATIONS WERE DONE
1,6X,4HNMOC,5X,3HNOX,7X,5HRATIO,5(6X,A4,6X,4HTIME))
366 FORMAT (1H1,//,14X,36HTHE FOLLOWING SIMULATIONS WERE DONE
1, 6X, 4HNMOC,11X,3HNOX,12X,5HRATIO,10X,5(A4,11X))
371 FORMAT (1H1,//,14X,36HTHE FOLLOWING SIMULATIONS WERE DONE
1,6X,4HNMOC,5X,3HNOX,7X,5HRATIO,5(6X,A4,6X,4HTIME))
END
fS
EHC,EXN,
i
L,XNIN,
./1HO/1H
./1HO/1H
./1HO/1H
./1HO/1H
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP '
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
AP
1
2
3
4
5
6
7
8
9
10
11
12
13
13A
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
35
36
37
38
39-
AP-1
-------
SUBROUTINE LINER
-------
DRAW THE ISOLINES
CALL WMNMX (SCR,11,11,11,OMIN,OMAX)
NW=0
DO 40 1=1,NL
WY(I)=9.
IF (OZP(I).LT.OMIN.OR.OZP(I).GT.OMAX) GO TO 40
NW=NW+1
WY(NW)=OZP(I)
40 CONTINUE
NCHR=4
NCNT=0
50 VAL=WY(1)*(10.**NCNT)
IF (VAL.GT.0.01) GO TO 60
NCNT=NCNT+1
GO TO 50
60 NCHR=NCHR+NCNT
REMB=WY(1)-FLOAT(IFIX(WY(1)*(10.**(NCNT+2))+0.1))/ (10.** (NCNT+2))
IF (REMB.GE.(0.001/(10.**NCNT))) NCHR=NCHR+1
IDG1=-(1000*NCHR+NW)
CALL CONMAP(SCR,11,11,11,XSIZE,YSIZE,WY,IDG1,KALCMP)
IF (KALCMP.LE.O) GO TO 130
CALL PLOT (0.5*XSIZE,0.5*YSIZE,-3)
CALL FRAME (0.,0.,0.,HC,HCC,HCX,HCM,IDIG1,0.,XN,XNC,XNX,XNM,IDIG2
1LBLBOT,12,LBLLFT,12,LBLTOP,1,LBLRGT,1)
NCNT=0
DO 70 1=1,36
IF (ITTL(I).NE.JBL) GO TO 80
NCNT=NCNT+1
70 CONTINUE
80 NLST=36-NCNT
DO 90 I=1,NLST
90 ITTL1(I)=ITTL(I+NCNT)
NCNT1=36
DO 100 1=1,36
ii = 37 - r
IF (ITTL1(II).NE.JBL) GO TO 110
NCNT1=NCNT1-1
100 CONTINUE
110 NCNT1=NCNT1-NCNT
ORGX=((HCC*HC)-(FLOAT(NCNT1)*4.*CHRZ))12.0
DO 120 I=1,NCNT1
CALL SYMBOL (ORGX,ORGY,CHRZ,ITTL1(I),IDUM,0.,2)
ORGX=ORGX+2.0*CHRZ
120 CONTINUE
CALL PLOT (10.,2.,999)
130 HCS=FLOAT(NW)
XNS=FLOAT(NLL)
CALL ISOPLT (HC,XN,3)
RETURN
END
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
/AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
AQ
59
60
61
62
63
64
64A
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110-
AQ-2
-------
SUBROUTINE EDGMX (X,Y,N,XMX,YMX,L)
CALCULATE THE MAXIMUM POINT ALONG A LINE
SAVE
DIMENSION X(N), Y(N)
LL=N
I=N
IF (N.LE.2) GO TO 30
NGO=0
DO 10 1=2,LL
IF (Y(I).GT.Y(I-l)) GO TO 10
IF (I.EQ.LL) L=I
(I.EQ.LL) NGO=1
(I.EQ.LL) GO TO 20
(Y(I) .GT.Yd+D) L=I+1
.GT.Yd+1) >
NGO=1
IF
IF
IF
IF (Y(I)
GO TO 20
10 CONTINUE
20 CONTINUE
IF (NGO.EQ.l) GO TO 40
30 L=LL-1
XMX=X(L+1)
YMX=Y(L+1)
RETURN
40 L=MAXO(L-1,3)
X21=X(L-l)-X(L-2)
X221=X(L-l)*X(L-l)-X(L-2)*X(L-2)
X32=X(L)-X(L-1)
XL2=X(L)*X(L)
Y21=Y(L-l)-Y(L-2)
C=(Y21/X21-(Y(L)-Y(L-l))/X32)/(X221/X21-(XL2-X(L-l)*X(L-l))/X32)
B—(Y21—C*X221)/X21
A=Y(L)-B*X(L)-C*XL2
XMX=-B*0.5/C
YMX=A+B*XMX+C*XMX*XMX
IF (XMX.GE.0.999*X(L)) YMX=Y(L)
IF (YMX.EQ.Y(L)) XMX=X(L)
IF (XMX.LT.1.001*X(L-2).AND.L.GT.3) GO TO 40
L=L-1
IF (XMX.LE.X(L)) L=L-1
RETURN
END
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
AR
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43-
AR-1
-------
c
SUBROUTINE ISOPLT (SAVHC,SAVNOX,IENTRY) AS 1
C
AS 2
C DRAWS A LINE PRINTER PLOT OF THE ISOPLETH AS 3
AS 4
SAVE AS 5
COMMON /NEED/ HC, XN, NL,OZ1 (20) , OZN (11, 11, 5) , MR, LS, HCS, XNS AS 6
COMMON /TITL/ ITTL(36) AS 7
COMMON /INOUT/ IN, IOUT, ITAPE, IALN, IALL, INHH, IOZC AS 8
COMMON /CALC/ NR, KR (200f 12) , A (200) , S (200) , R (200) , ITYPE (200) , AS 9
1 IA(60),JA(800),DILUT, TEMP, ERR, START, STOPP, AS 9A
2 TPRNT,TSTEP,ZENI AS 10
C COMMON /PHOTON/ JGRID (101, 42) , SPRSE (13) AS 11
COMMON /CNTRL/ SIG, SIGMA, INFO, NPTO, TSRT, DTIM, Zl, Z2, DCON, EHC, EXN, AS 12
1 FLST,TLST AS 13
COMMON /SPEC/ NS,CARB(20),RCTY(20),XNF(2),IH(20),INOX(2), AS 14
1 FINHC(20),FALHC(20),NHC,OZIN,OZAL,HCIN,HCAL,XNIN, AS 15
2 XNAL,NOZ,FENX(2),C(61),NI,KOZ(5) AS 16
C COMMON /GEAR6/ DDM1 (880) , XZP (20) , DUM2 (326) , DUM3 (972) AS 17
C COMMON /GEAR6C/ NGRID(101,2) AS 17A
COMMON /HOUR/ OZM(5) ,NGO, TM, DUMMM(5) AS 18
COMMON /SCRAT3/ OZP(20) AS ISA
COMMON /SCRATC/ ISPN AS 19
COMMON /CALCHR/ SPECIS(61) AS 1 9A
COMMON /SPECHR/ HCSPEC(20), PLSP(5), REACT (61) AS 19B
DIMENSION TVERT(52,2), TPRINT(ll), NLINE(3) AS 20
DIMENSION TV(7), SAVDAT(lOl), TV1(7) AS 21
DIMENSION JGRID(101,42), NGRID (101,2) , DUM3(101) AS 21A
C Ag 2 IB
CHARACTER*! JPLUS, JBAR, JSYMB, JBL AS 2 1C
CHARACTER*! JGRID, NGRID, NLINE AS 2 ID
CHARACTER*:? ITTL AS 21E
CHARACTER* 4 JBLANK, TV, TVERT, ISPN AS 2 IF
CHARACTER*4 SPECIS, HCSPEC, REACT, PLSP AS 21G
C AS 22
DATA JBLANK/' ' /, MAXHC/101/, MAXNOX/42/, TGRID/100 . /, AS 23
1CGRID/42./,, JPLUS/' +'/, JBAR/'I'/, JSYMB/' +'/, JBL/' '/ AS 24
DATA TV/' N ',' 0 ',' X ',' ' , ' P ' , ' P ' , ' M ' / AS 25
DATA TVERT/104*' '/ AS 26
AS 27
C EMULATE MULTIPLE ENTRY POINTS WITH COMPUTED GO TO AS 28
GO TO (10, 90, 120), IENTRY AS 29
STOP AS 30
10 CONTINUE As 31
NR1=1 AS 32
DO 20 J=l,42 AS 33
IF (J.LE.2) NGRID (1,J)=JBAR As 34
IF (J.LE.2) NGRID ( 10 1,J)= JBAR AS 35
JGRID (1,J)= JBAR AS 36
JGRID ( 10 1,J)=JBAR AS 37
20 CONTINUE As 3Q
DO 30 1=1,52 AS 39
TVERT (1,1) == JBLANK As 4 0
IF (I.LT.17.0R.I.GT.23) GO TO 30 AS 41
K=I-16 Ag 42
TVERT(I,1)=TV(K) As 43
30 CONTINUE As 44
DO 40 1=1,101 AS 45
40 SAVDAT(I)=0. AS 46
DO 50 J=l,42,3 AS 47
JGRID (1,J)=JPLUS AS 4Q
JGRID ( 10 1,J)=JPLUS AS 49
50 CONTINUE AS 5Q
C AS 51
AS-1
-------
SET NORMALIZATION FACTORS AND VERTICAL LABELS
CLOW=0.
TLOW=0.
CHIGH=XN
CSPAN=CGRID/CHIGH
THIGH=HC
DO 60 1=1,7
M-8-I
TV1(I)=(FLOAT(M)/7.)*CHIGH
60 CONTINUE
TSPAN=TGRID/THIGH
DO 70 J=l,ll
TPRINT(J)=(FLOAT(J-l)/10.)*THIGH
70 CONTINUE
CLEAR GRID
MAXHC1=MAXHC-1
DO 80 K=1,MAXNOX
DO 80 J=2,MAXHC1
JGRID(J,K)=JBLANK
IF (K.LE.2) NGRID(J,K)=JBLANK
80 CONTINUE
RETURN
ENTRY FOR SAVING INTERPOLATED POINTS
ENTRY SAVLIN
90 CONTINUE
KHC=IFIX((SAVHC-TLOW)*TSPAN+1.5)
KNOX=IFIX((SAVNOX-CLOW)*CSPAN-0.5)
KNOX=MAXNOX~KNOX
IF (KNOX.LT.l) GO TO 110
IF (KNOX.GT.MAXNOX) GO TO 110
IF (KHC.LT.l) GO TO 110
IF (KHC.GT.MAXHC1) GO TO 110
JGRID(KHCfKNOX)=JSYMB
IF (TM.EQ.1..AND.NPTO.EQ.O) DUM3(NR1)=FLOAT(KHC)
IF (TM.EQ.l.) NR1=NR1+1
IF (KHC.LT.2) GO TC 110
100 CONTINUE
110 RETURN
ENTRY FOR PLOTTING GRID
ENTRY LINPRT
120 CONTINUE
NPL=IFIX(HCS+0.1)
NLL=IFIX(XNS+0.5)
KOUNT=0
IF (NLL.EQ.O) GO TO 160
NJ=1
130 NJ=NJ+1
J=MAXNOX-NJ
IF (JGRID(3,J).EQ.J3LANK) GO TO 130
KOUNT=KOUNT+1
IF (KOUNT.GT.NLL) GO TO 150
IF (NJ.GT.MAXNOX-1) GO TO 150
NVAR=IFIX(OZP(KOUNT)*100.+0.5)
CALL CONVT (NVAR,NLINE,3)
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
AS-2
-------
DO 140 11=1,3
112=11+2
140 IF (NLINE(II) .NE.JBL) JGRID (112, J) =NLINE (II)
NJ=NJ+1
GO TO 130
150 KOUNT-KOUNT-1
160 KOUNT=KOUNT+1
NR1-NR1-1
DO 180 I=KOUNT,NR:L
NVAR=IFIX(OZP(I) *100.-i-0.5)
CALL CONVT (NVAR, NLINE, 3)
KHC=IFIX (DUM3 ( I ) +0 . 1 )
DO 170 11=2,3
170 IF (NLINE(II) .NE.JBL) NGRID (KHC, II-l) =NLINE (II)
180 CONTINUE
WRITE (IOUT,220) ( (NGRID (I, J) , 1=1, 101) , J=l, 2)
KFRST=1
DO 190 K=KFRST,MAXNOX
L=MOD((K-1),6)
IF (L.EQ.O) WRITE (IOUT,230) TVERT (K, 1) , TV1 ( I) , ( JGRID ( J, K) , J=l ,
1 HC )
IF (L.NE.O) WRITE (IOUT,240) TVERT (K, 1 ), (JGRID (J, K) , J=l, MAXHC)
190 CONTINUE
WRITE (IOUT,250) CLOW
WRITE (IOUT,260) TPRINT
WRITE (IOUT,270) ( ITTL (I) , 1=1, 36)
IF (NPTO.EQ.O) WRITE (IOUT,280) ISPN, (OZP ( I) , 1=1 , NPL)
200 RETURN
210 FORMAT (1H1/////////9X, A4 , F5 . 3, 1H+, 10 (10H +) )
220 FORMAT (1H1//////18X,1H+,10(10H +)/18X,101A1/18X,101A1)
230 FORMAT (9XfA4,F5.3,101A1)
240 FORMAT (9X,A4,5X,101A1)
250 FORMAT (13X, F5 . 3 , 1H+, 10 (10H + ) )
260 FORMAT (F21.3,10F10.2/64X,11HNMOC (PPMC)//)
270 FORMAT (46X,36A2)
280 FORMAT (1HO/20X,4HTHE ,A4,12H LINES ARE ,10F8.5/40X,10F8 5)
END
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
MAXAS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
AS
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155-
AS-3
-------
SUBROUTINE WMNMX (Z,ND1,NX,NY,ZMIN,ZMAX) AT l
AT 2
C *** RETURNS THE MINIMUM AND MAXIMUM VALUES OF AN ARRAY AT ?
C GWL/SAI DEC 77 "i A
C AI *
SAVE
RETURN
END
DIMENSION Z(ND1,1) AT 7
ZMIN = +1.E20 JT q
ZMAX = -1.E20 A* 1Q9
DO 20 J=1,NY ^ JJ
DO 10 1=1, NX £i ;;
ZU-Zd.J) ^ ]l
AT 1 5
IF (ZIJ .LT. ZMIN) ZMIN = ZIJ AT 16
IF (ZIJ .GT. ZMAX) ZMAX = ZIJ AT , -7
10 CONTINUE J; ^
20 CONTINUE a T- i o
AI 1 9
AT 20
AT 21
AT 22
AT-1
-------
SUBROUTINE CONMAP (Z,ND1,NOX,NOY,SIZX,SIZY,C,NLEV,KALCM1) AU 1
SAVE AU 2
C AU 3
C *** PURPOSE — DRAWS A CONTOUR MAP AU 4
C GW LUNDBERG/SAI JULY 87 AU 5
C AU 6
C Z THE (ORIGIN OF THE) ARRAY TO BE CONTOURED AU 7
C ND1 THE FIRST DIMENSION OF Z AU 8
C NOX THE NUMBER OF ELEMENTS OF Z TO USE IN X-DIRECTION AU 9
C NOY THE NUMBER IN THE Y-DIRECTION AU 10
C SIZX INCHES/CELL IN THE X-DIRECTION AU 11
C SIZY INCHES/CELL IN THE Y-DIRECTION AU 12
C C THE CONTOUR LEVELS TO DRAW AU 13
C NLEV MOD(lABS(NLEV),1000) IS THE NUMBER OF LEVELS AU 14
C IF NLEV<0, THE CONTOURS ARE LABELED WITH AU 15
C -NLEV/1000 DECIMAL DIGITS OF PRECISION AU 16
C IF NLEV>=1000, THE CONTOURS ARE LABELED AU 17
C NLEV/1000, NLEV/1000+1, ,NLEV/1000+NL-1 AU 18
C AS INTEGERS WHERE NL=MOD(NLEV,1000) AU 19
AU 20
C *** NOTE — MISSING DATA CELLS ARE NOT MAPPED AU 21
AU 22
DIMENSION Z(11,1),C(1) AU 23
LOGICAL NOLBL AU 24
COMMON /WCONM/ IX, JY, IDX, JDY, NBR, LOOP, NPf NTBL (1000) , NR, AU 25
1 NX,NY,XSIZ,YSIZ,XXFLG,KALCMP AU 26
COMMON /WLB1/ FACT, D 1ST, CHRSZ,NCHR,OZL AU 27
DATA NR1/1000/ Au 2Q
NR=NR1 AU 29
KALCMP=KALCM1 AU 3Q
C AU 31
C *** MOVE ARGUMENTS TO COMMON AU 32
NX = NOX AU 33
NY = NOY AU 34
XSIZ = SIZX AU 35
YSIZ = SIZY AU 3g
c
C *** SET THE NUMBER OF LEVELS REQUESTED AU 38
NC = MOD(TABS(NLEV),1000) AU 39
AU 40
C *** ASSUME NO LABELS AU 41
NOLBL = .TRUE. AU 42
AU 4 3
C *** SET LABEL SIZE JUST IN CASE AU 44
SIZLBL =0,07 AU 45
C *** SET UP LABELING PARAMETERS AS REQUESTED AU 46
IF (NLEV .GT. 0) GO TO 10 AU 47
C AU 48
NDEC = -NLEV/1000 AU 4g
IF (NDEC .EQ. 0) NDEC = -1 Au 5Q
NOLBL = .FALSE. AU 51
c G0 T0 20 AU 52
10 IF (NLEV .LT. 1000) GO TO 20 an 54
LOW = NLEV/1000 - 1 an SR
NDEC = -1 AU 56
NOLBL = .FALSE. AU 5°
P AU 58
AU 5 9
C *** FOR EACH LEVEL, LOCATE THE STARTING POINT OF EACH AU 60
C CONTOUR, THEN CALL VVCMAP TO DRAW THE LINE AU fil
20 DO 120 L=1,NC AU ^
C NORMALIZE THE CONTOUR LEVEL AU 64
AU-1
-------
30
C
C
C
C
C
C
C
C
C
C
C
40
50
C
C
60
70
C
C
C
CV = C(L)/2.0
CV = CV*2.0
*** SET UP LABELS IF REQUESTED
IF (NOLBL) GO TO 30
OZL = CV
NP = 0
*** IN THE FOLLOWING, (IX, JY) IS THE GRID POINT (NODE)
JUST HIGHER THAN CV. NBR IS ONE OF FOUR NEIGHBORING
NODES (1=WEST, 3=N, 5=E, 7=S) TO BE USED WITH (IX, JY) TO
INTERPOLATE THE COORDINATES OF THE CONTOUR. IDX AND JDY
INDICATE THE DIRECTION OF THIS NEIGHBOR.
AU
AU
•» f»
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
*** SCAN THE FOUR EDGES FOR OPEN CONTOURS. THIS SCAN CLEVERLYAU
CAPTURES EVERY OPEN CONTOUR EXACTLY ONCE An
LOOP = 0
*** SCAN BOTTOM AND TOP EDGE
DO 50 1=2, NX
IM1 - 1-1
IF (Z(IM1,1) .GE. CV .OR. Z(I,1) . LT . CV) GO TO 40
IX = I
JY = 1
IDX = -1
JDY = 0
NBR = 1
CALL WCMAP (Z,ND1,CV)
IF (Z(I,NY) .GE. CV .OR. Z(IM1,NY) .LT. CV) GO TO 50
IX = IM1
JY = NY
TDX = 1
-L U f\ J.
JDY = 0
W U X \J
NBR = 5
CALL WCMAP (Z,ND1,CV)
CONTINUE
*** SCAN RIGHT AND LEFT EDGE
DO 70 J=2,NY
JM1 = J-l
IF (Z(NX,JM1) .GE. CV .OR. Z (NX, J) . LT . CV) GO TO 60
IX = NX
JY = J
IDX = 0
JD Y = — 1
NBR = 7
CALL WCMAP (Z,ND1,CV)
IF (Z(1,J) .GE. CV .OR. Z(1,JM1) . LT . CV) GO TO 70
IX = 1
JY == JM1
IDX = 0
JDY = 1
NBR = 3
CALL WCMAP (Z,ND1,CV)
CONTINUE
*** SCAN CENTER REGION FOR CLOSED LOOPS — IT IS SUFFICIENT
TO CHECK ONLY THE WEST NEIGHBOR AT EACH NODE
LOOP = - 1
NYM1 = NY-1
AU
AU
AU
•JL ft
AU
» FT
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
AU
65
66
67
68
69
\J J
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
8 6
8 7
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
AU-2
-------
DO 110 J=2,NYM1 AU 129
DO 100 1=2,NX AU 130
IM1 = 1-1 AU 131
IF (Z(IM1,J) .GE. CV .OR. Z(I,J) .LT. CV) GO TO 100 AU 132
AU 133
C *** CHECK IF NODE ALREADY USED AU 134
NODE = 1000*1 + J AU 135
IF (NP .EQ. 0) GO TO 90 AU 136
DO 80 K=1,NP AU 137
IF (NODE .EQ. NTBL(K)) GO TO 100 AU 138
80 CONTINUE AU 139
C AU 140
C *** TAG THIS NODE TO PREVENT RETRACE AU 141
90 NP = NP+1 AU 142
IF (NP .GT. NR) GO TO 120 AU 143
NTBL(NP) = NODE AU 144
AU 145
C *** SET PARAMETERS AND DRAW LOOP AU 146
IX = I
JY = J
IDX = -:
= o
AU 147
AU 148
AU 149
AU 150
NBR = * AU 151
CALL WCMAP (Z,ND1,CV) AU 152
100 CONTINUE AU 153
110 CONTINUE AU 154
120 CONTINUE AU 155
C AU 156
RETURN AU 157
END AU 158-
AU-3
-------
SUBROUTINE WCMAP (Z,ND1,C) AV i
SAVE L
c AV 2
AV 3
C *** PURPOSE ~ TRACES AND DRAWS A CONTOUR GIVEN THE BEGINNING AV 4
C BY CONMAP AV
C GW LUNDBERG/SAI JULY 87 £v 6
AV 7
C Z THE (ORIGIN OF THE) ARRAY TO BE CONTOURED AV
C ND1 THE FIRST DIMENSION OF Z AV Q
fl
AV
C C THE CONTOUR LEVEL TO DRAW £v 10
W
DIMENSION Z(ND1,1),INX(8),JNY(8),UT(11),VT(11),TM(20),YP(20) AV 12
COMMON /WCONM/ IX, JY, IDX, JDY, NBR, LOOP, NP, NTBL (1000) ,NR, AV 13
1 NX,NY,XSIZ,YSIZ,XXFLG,KALCMP AV 14
COMMON /CNTRL/ SIG, SIGMA, INFO, NPTO, TSRT, DTIM, Zl, Z2, DCON, EHC, EXN, AV 15
1 FLST,TLST Av ,fi
DATA INX /-I, -1,0,1,1,1,0, -I/ ™ }*
DATA JNY /O, 1,1, 1,0, -!,-!,-!/ ™ ]l
C DATA FUZZ/0.003/ „. ,n
C
cv = c AV 20
C AV 21
AV 2?
C *** SAVE STARTING NODE AND CURRENT NEIGHBOR AV ->\
IXO = IX ™ J3
JYO = JY AV 24
NBRO = NBR A^ 25_
c AV 26
C *** SET THE SECOND POINT FOR INTERPOLATION AV 9fl
1X1 = IX + IDX A; 28
JY1 = JY + JDY ^ ;^
c AV 3 0
C MODE^ EiTHER P°INT MISSING — IGNORE WITH VVKURV MODE RESET AV 32
IF (Z(IXrJY) .EQ. XXFLG .OR. Z(IX1,JY1) .EQ. XXFLG) AV II
c 1 G° T° 3° AV 35
C *** INTERPOLATE FOR THE FIRST POINT AND SAVE AV 17
IF (IDX .EQ. 0) GO TO 10 £w ^Q
Y = JY AV ja
AV 1 Q
X = (Z(IXfJY)-CV)/(Z
-------
C IS TERMINATED ALTHOUGH THE SCAN CONTINUES. THE CONTOUR AV 65
C REAPPEARS WHEN BOTH NODES ARE AGAIN KNOWN. AV 66
30 NBR = NBR + 1 AV 67
IF (NBR .GT. 8) NBR = NBR - 8 AV 68
IDX = INX(NBR) AV 69
JDY = JNY(NBR) Av 70
1X1 = IX + IDX AV 71
JY1 = JY + JDY AV 72
IF (LOOP .NE. 0) GO TO 40 AV 73
C Ay -7 4
C *** CHECK FOR END OF OPEN CONTOUR AV 75
IF (1X1 .GT. NX .OR. 1X1 .LT. 1 .OR. AV 76
1 JY1 .GT. NY .OR. JY1 .LT. 1) GO TO 200 AV 77
C Ay -j 8
C *** CHECK IF POINT BELOW LEVEL AV 79
40 IF (CV .GT.. Z(IX1,JY1)) GO TO 60 AV 80
AV 81
C *** REVERSE NODES AND GO ON (UNLESS CELL IS DEGENERATE) AV 82
C IF (MOD(NBR,2) .NE. 0) GO TO 120 AV 83
C AV 84
NNBR = NBR+1 AV 85
IF (NNBR .GT. 8) NNBR = NNBR-8 AV 86
NX1 = IX -I- INX(NNBR) . AV 87
NY1 = JY + JNY(NNBR) AV 88
AV 8 9
C *** BE CAREFUL OF EDGE AV 90
IF (NX1 .GT. NX .OR. NX1 .LT. 1 .OR. AV 91
1 NY1 .GT. NY ..OR. NY1 .LT. 1) GO TO 50 AV 92
C AV 93
C *** TEST FOR DEGENERACY AV 94
IF (CV .LE. Z(NX1,NY1)) GO TO 50 AV 95
C AV 96
C *** CELL IS DEGENERATE — ESTIMATE CENTER HEIGHT AV 97
ZCEN = 0.25 * (Z(IX,JY)+Z(IX,JY1)+Z(IX1,JY1)+Z(IX1,JY)) AV 98
C AV 99
C *** PUNT IF CENTER LOW AV iQO
IF (CV .GT. ZCEN) GO TO 30 AV 1Q1
C AV 102
50 NBR = NBR +4 Av 103
ix = ixi AV 104
GO TO 30 AV Joe
C AV 107
C *** MAY BE OK — BUT CHECK FOR MISSING POINT AV 108
60 IF (Z(IX,JY) .NE. XXFLG .AND. Z(IX1,JY1) .NE. XXFLG) AV 109
1 GO TO 70 AV no
I AV 111
C *** ONE POINT MISSING — FLUSH SPLINE BUFFER TO SET AV 112
C FOR A BROKEN LINE SEGMENT IF NECESSARY AV 113
IF (MODE .EQ. -1) GO TO 180 AV 114
CALL VVKURV (DUM,DUM,2) AV 115
c G0 T0 18° AV 116
C *** LOOKS OK — INTERPOLATE FOR X AND Y AV 118
C AV 119
C *** BUT MAY BE A DIAGONAL NODE AV 120
70 IF (MOD(NBR,2) .EQ. 0) GO TO 30 AV i?1
IF (IDX .EQ. 0) GO TO 120 AV 122
Y = JY AV 123
C X = (Z(IX,JY)-CV)/
-------
IPTS=IX
DO 80 JJ=1,IX
UT(JJ)=Z(JJ, JY)
VT(JJ)=FLOAT(JJ)
80 CONTINUE
GO TO 110
90 IPTS-12-IX
DO 100 JJ=1,IPTS
UT(JJ)=Z(12-JJ,JY)
VT(JJ)=FLOAT(12-JJ)
100 CONTINUE
C
110 SX=-SIG*30.
IF (IPTS.GT.2) SX=-SIG*20./(FLOAT(IPTS-2)**2)
CALL CURV1(IPTS,UT,VT,SP1,SP2,YP,TM,SX)
IT=1
X=CURV2(CV,IPTS,UTrVT,YP,SX, IT)
C
GO TO 170
C
120 X = IX
C Y = (Z(IX,JY)-CV)/(Z(IX,JY)-Z(IX,JY1))*JDY + JY
C
C USE SPLINE FIT OF DATA
C
IF (JDY.GT.O) GO TO 140
IPTS=JY
DO 130 JJ=1,JY
UT(JJ)=Z(IX,JJ)
VT(JJ)=FLOAT(JJ)
130 CONTINUE
GO TO 160
140 IPTS=12-JY
DO 150 JJ=1,IPTS
UT(JJ)=Z(IX,12-JJ)
VT(JJ)=FLOAT(12-JJ)
150 CONTINUE
C
160 SX=-SIG*30.
IF (IPTS.GT.2) SX=-SIG*20./(FLOAT(IPTS-2)**2)
CALL CURV1(IPTS,UT,VT,SP1,SP2,YP,TM,SX)
IT=1
Y=CURV2(CV,IPTS,UT,VT,YP,SX, IT)
*** SCALE AND SEND
170 XHH=X
YHH=Y
X = (X-0.5)*XSIZ
Y = (Y-0.5)*YSIZ
WRITE (9,1111) XHH,YHH,CV
1111 FORMAT (1P,3E13.4)
CALL VVKURV (X,Y,MODE)
*** RESET MODE
MODE = 0
*** SET NODE IN NTBL SO ITS NOT RETRACED
180 IF (NBR .NE. 1) GO TO 190
NP = NP + 1
IF (NP .GT. NR) GO TO 200
NTBL(NP) = 1000*IX + JY
*** CHECK IF LOOP COMPLETE
190 IF (LOOP .EQ. 0) GO TO 30
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
AV
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
173A
173B
174
175
175A
175B
176
177
178
179
180
181
182
183
184
185
186
187
188
AV-3
-------
IF (IX .NE. IXO) GO TO 30 AV 189
IF (JY .NE. JYO) GO TO 30 AV 190
IF (NBR .NE. NBRO) GO TO 30 AV 191
C AV 192
C *** ALL DONE — FINISHED OFF THIS LINE AND RETURN AV 193
200 CALL WKURV (X,Y,1) AV 194
RETURN AV 195
END AV 196-
AV-4
-------
SUBROUTINE WKURV (XPT, YPT, MODE)
SAVE
C
C
C
C
C
r
C
c
C
r
C
C
t»
c
c
C
c
PITTED LINE BY SECTIONS
*** NOTE — THE POINTS ARE RECEIVED ONE AT A TIME
XPT
EL
MODE
NODE X COORDINATE IN INCHES FROM CURRENT PLOT ORIGIN
N°DE Y COORDINATE IN INCHES FROM CURRENT PLOT ORIGIN
<0, INITIAL POINT OF FIRST SECTION
=0, ADDITIONAL POINT
-1, FLUSH THE BUFFER — XPT,YPT FORCED
=2, FLUSH THE BUFFER — XPT,YPT IGNORED
*** NOTE — THIS CODE PROVIDES FOR BROKEN SPLINED LINES.
o~EDMODE=1 T° TERMINATE THE SUBLINE. A NEW LINE IS
STARTED WITH MODE— 1, OR A NEW SUBLINE WITH MODE=0 .
THIS FEATURE IS USED BY CONMAP FOR MISSING DATA.
LOG
NPTS T0 ZERO
™ERE
rn/ F°R A DESCRIpTION OF THESE VARIABLES
COMMON /WCONM/ IDUM (1010) , XSIZ, YSIZ, XXFLG, KALCMP
COMMON /WKRV/ NPTS, NSLP, SLP1 , SLPN, LSLP, TANGNT, Sf
1 X(32)fY(32),XP(32),YP(32)
COMMON /WLB1/ FCTR, DIST, CHRSZ, NCHR, OZLBL
COMMON /HOUR/ OZR (5) , NGG, TMr DUM (5)
COMMON /NEED/ HC( XN, NL, OZP (20) , OZN (11, 11 , 5) , MR, LS, HCS, XNS
DATA STEP/0.04/, MXPT/31/, FUZZ/0 . 05/, NPTS1/0/
DATA TANN/0./,LSLP1/0/,IFRST/1/
IF (IFRST.EQ.l) NPTS=NPTS1
IF (IFRST.EQ.l) LSLP=LSLP1
IFRST=2
*** JUMP TO APPROPRIATE CODE
IF (MODE) 10,20,60
ENTRY FOR MODE LESS THAN ZERO
10 NSECTN =1
USX=(XPT-0.5)*HC*.1/XSIZ
USY=(YPT-0.5)*XN*.1/YSIZ
TM=1.
CALL ISOPLT(USX,USY,2)
TM=2.
(XPT'YPT'3>
YSTRT = YPT
X(l) = XPT
Y(l) = YPT
NPTS =1
*** ZERO KNOWN SLOPE FLAG
KSLP =0
RETURN
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
1
2
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
23
24
25
26
27
28
30
32
3"
37
38
39
40
41
42
43
44
45
47
48
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
AW-1
-------
AW 65
AW 66
C ENTRY FOR MODE EQUAL ZERO AW 67
*********** ^ g g
AW 69
20 IF (NPTS .GT. 0) GO TO 30 AW 70
C AW 71
C *** THIS IS THE CONTINUATION OF A BROKEN LINE (SEE AW 72
C CONMAP) — SET PEN Aw 73
IF (KALCMP.GT.O) CALL WLABL (XPT,YPT,3) AW 74
GO TO 40 AW 75
C AW 76
C *** SAVE POINT (IF NOT TOO CLOSE TO LAST POINT) AW 77
C IN BUFFER — FLUSH WHEN FULL AW 78
30 IF (ABS(X(NPTS)-XPT) .LT. FUZZ .AND. AW 79
1 ABS(Y(NPTS)-YPT) .LT. FUZZ) RETURN AW 80
40 NPTS = NPTS+1 AW Q1
X(NPTS) = XPT AW 82
Y(NPTS) = YPT AW 83
IF (NPTS .LT. MXPT) RETURN Aw 84
AW 85
C *** FLUSH THE BUFFER — SUPPLY STARTING SLOPE IF AVAILABLE AW 86
NSLP = KSLP AW 87
SLP1 = TANN • AW 88
AW 8 9
CALL VVKRV1 AW 9Q
AW 91
C *** SET NUMBER OF POINTS TO INTERPOLATE AND NORMALIZED STEP SIZE AW 92
N = S/STEP - 1 AW 93
FACT = STEP/S AW 94
DIST=S AW 95
C *** SAVE THE SLOPE FOR FIRST SECTION ONLY AW 97
IF (NSECTN .EQ. 1) TAN1 = SLP1 AW 98
AW 99
C *** INITIALIZE WKRV2 (PEN ALREADY THERE) AW i0n
CALL VVKRV2( 0.,XX,YY) AW 101
AW 102
C *** PLOT THE MIDDLE INTERPOLATED POINTS AW
DO 5o I-!*
T = -FLOAT(I)*FACT AW 105
CALL VVKRV2 (T,XX,YY) AW 1Q6
USX=(XX-0.5)*HC*.1/XSIZ AW 107
USY=(YY-0.5)*XN*.1/YSIZ m 108
CALL ISOPLT(USX,USY,2) Aw 109
IF (KALCMP.LE.O) GO TO 50 AW no
CALL VVLABL (XX,YY,2) Aw
50 CONTINUE AW
AW 113
C *** GET SLOPE AT LAST POINT, SAVE, AND PLOT LAST SEGMENT AW 114
CALL VVKRV2 <-l.,XX,YY) AW
TANN = SLPN AW
USX=(XX-0.5)*HC*.1/XSIZ AW
USY=(YY-0.5)*XN*.1/YSIZ AW
CALL ISOPLT(USX,USY,2) AW ng
IF (KALCMP.GT.O) CALL WLABL (XX,YY,2) AW 12Q
AW
C *** BUMP SECTION COUNT AW
NSECTN = NSECTN + 1 Aw
AW 124
C *** MAKE THE LAST POINT THE FIRST FOR THE NEXT SECTION AW 125
X(l) = X(NPTS) A^
Yd) = Y(NPTS) ™
NPTS =1
Nt^ib L AW 128
AW-2
-------
*** FLAG FIRST SLOPE AS KNOWN
KSLP = 1
RETURN
ENTRY FOR MODE GREATER THAN ZERO
*** FLUSH THE BUFFER
*** PUNT IF ONLY FLUSHING
60 IF (MODE .EQ. 2) GO TO 70
*** FORCE FINAL POINT IF NOT ALREADY ENTERED
IF (X(NPTS) .EQ. XPT .AND. Y(NPTS) .EQ. YPT) GO TO 70
*** THERE IS ALWAYS AN EXTRA POSITION IN X AND Y
NPTS = NPTS+1
X(NPTS) = XPT
- YPT
C
C-
c
c
c
c
c
c
*** IGNORE SINGLE OR NULL POINT
— START OF FIX 7/17/37
70 IF (MODE .NE. 2) GO TO 80
IF (NPTS .EQ. 1) KSPL = 0
IF (NPTS .LE. 1) NPTS = 0
80 IF (NPTS .LE. 1) RETURN
— END OF FIX 7/17/87
*** CHECK FOR SIMPLE LINE — ONLY ONE SECTION
IF (NSECTN .GT. 1) GO TO 110
*** TWO POINT LINES TAKE SPECIAL TREATMENT
IF {NPTS .GT. 2) GO TO 90
*** TWO POINTS — DRAW
USX=(X(1)-0.5)*HC*.1/XSIZ
USY=(Y(1)-0.5)*XN*.1/YSIZ
CALL ISOPLT(USX,USY,2)
USX=(X(2)-0.5)*HC*.1/XSIZ
USY=(Y{2)-0.5)*XN*.1/YSIZ
CALL ISOPLT(USX,USY,2)
IF (KALCMP.LE.O) GO TO 160
CALL WLABL (X (1) , Y (1) , 3 )
CALL WLABL (X (2) , Y (2) , 2)
CALL WLABL (DUM,DUM,1)
AND RETURN
*** SIMPLE BUT MAY BE A LOOP
90 IF (X(NPTS) .EQ. XSTRT .AND
*** A SIMPLE SIMPLE LINE
NSLP =0
CALL VVKRV1
GO TO 130
*** SIMPLE LOOP
100 NSLP = -1
CALL VVKRV1
GO TO 130
Y(NPTS) . EQ . YSTRT) GO TO 100
132
133
134
135
136
AW 1 9 Q
AW
AW
AW
Aw
AW
AW
AW 142
AW 143
AW 144
AW 1 4 5
AW 146
"®
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
174
1-70
179
AW 170
AW
AW
AW
™
AW
aw
AW
AW
n
AW 189
AW 19°
AW 191
AW 192
182
186
1 8 7
AW-3
-------
*** COMPLEX LINE AND MAY BE LOOP
110 IF (X(NPTS) .EQ. XSTRT .AND. Y(NPTS)
*** COMPLEX OPEN LINE
NSLP = 1
SLP1 = TANN
CALL WKRV1
GO TO 130
*** COMPLEX LOOP
120 NSLP = 3
SLP1 = TANN
SLPN = TAN1
CALL WKRV1
.EQ. YSTRT) GO TO 120
*** JUST MARK THE POINT IF ARC LENGTH SMALL
130 IF (S .GT. 0.01) GO TO 140
IF (KALCMP.LE.O) GO TO 160
CALL PLOT (XSTRT,YSTRT,3)
CALL PLOT (XSTRT,YSTRT,2)
GO TO 160
*** PLOT THE FINAL SECTION
140 N = S/STEP - 1.
FACT = STEP/S
DIST = S
CALL WKRV2 (0.,XX,YY)
DO 150 1 = 1,.N
T = -I*FACT
CALL WKRV2 (T,XX,YY)
USX=(XX-0.5)*HC*.1/XSIZ
USY=(YY-0.5)*XN*.1/YSIZ
CALL ISOPLT(USX,USY,2)
IF (KALCMP.LE.O) GO TO 150
CALL VVLABL (XX,YY,2)
150 CONTINUE
CALL VVKRV2 (-l.,XXfYY)
USX=(XX-0.5)*HC*.1/XSIZ
USY=(YY-0.5)*XN*.1/YSIZ
CALL ISOPLT(USXfUSY,2)
IF (KALCMP.LE.O) GO TO 160
CALL VVLABL (XX,YY,2)
CALL VVLABL (DUM,DUM,1)
160 NPTS = 0
KSLP = 0
RETURN
END
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
AW
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242-
AW-4
-------
SUBROUTINE WLABL (X2,Y2,IPEN)
SAVE A* l
C AX 2
C *** SETS A LINE LABEL INTO A VECTOR PLOT PROVIDING THAT AX 4
C PARAMETERS IN /WLBL/ Vy I
C GW LUNDBERG/SAI AUG 87 VC c
C AX °
C X2,Y2 THE TERMINAL POINT OF THE CURRENT VECTOR £v 1
C IN INCHES FROM PRESENT PLOT ORIGIN AX Q
C IPEN =3, INITIALIZE — SET PEN TO X2,Y2 AX 10
C =2, CONTINUE — DRAW LINE WITH LABEL TO X2,Y2 AX 11
C -1, FINISH — COMPLETE LINE J£ \\
C *** NOTES — AX 13
C (1) THE VALUES FOR IPEN MAY APPEAR WHIMSICAL, BUT THEY AX 1«5
FOLLOW THE PRECEDENT SET BY SUBROUTINE PLOT
•> - •
FOR AX 17
C THE FIRST LABEL WHICH STARTS FRST INCHES FROM AX 18
C THE BEGINNING OF THE VECTOR PLOT — THIS PROVIDES FOR AX 19
C STAGGERED LABELS. ££ ^
DIMENSION XSV(100),YSV(100) ^ *\
C AX
-------
AX 63
C *** IF THERE ARE TO BE NO LABELS — PLOT THE VECTOR AND RETURN AX 64
20 IF (NCHR .GT. 0) GO TO 30 AX 65
CALL PLOT (X2,Y2,2) AX 66
RETURN AX 67
^ AX 68
C *** IF SEEKING ROOM FOR THE LABEL -- SKIP FOLLOWING AX 69
30 IF (NSV .GT. 0) GO TO 50 AX 70
C AX 71
C *** CALCULATE THIS VECTOR LENGTH AND ADD TO THE ACCUMULATED AX 72
C LENGTH.. IF A LABEL IS TO START IN THIS VECTOR, SKIP TO AX 73
C 120, ELSE PLOT THE VECTOR AND RETURN AX 74
VECSZ = SQRT {(X2-X1)**2 + (Y2-Y1) **2) AX 75
TOTSZ = TOTSZ + VECSZ AX 76
IF (TOTSZ ..GT. SKPSZ) GO TO 40 AX 77
CALL PLOT (X2,Y2,2) AX 78
XI = X2 AX 79
Y1 ~ Y2 AX 80
RETURN M 81
AX 82
C *** ITS TIME FOR A LABEL — LOCATE START AX 83
40 RATIO = (VECSZ - TOTSZ + SKPSZ) /VECSZ AX 84
X1L = XI + RATIO* (X2-X1) AX 85
Y1L = Yl + RATIO* (Y2-Y1) AX 86
AX 8 7
C *** PLOT SUBVECTOR AND REMEMBER THE END POINT AX 88
CALL PLOT
-------
ESCAPES ME
80 A = (X2-X1)**2 + (Y2-Y1)**2 ?C ,;«
B = -2*«X1L-X1)*(X2-X1) + (Y1L-Y1) MY2-Y1) ) AX 129
C = (X1L-X1)**2 + (Y1L-Y1)**2 - SZLBL*SZLBL AX 130
SQRTD = SQRT(B*B - 4*A*C) ?? "*
Tl = (-B + SQRTD)/ (2*A)
T2 = (-B - SQRTD) /(2*A) .
C *** PICK THE MINIMUM T BETWEEN 0-1 (MUST BE ONE) AX 136
IF (T2 !LT.' o!) T2 - i! ??
RATIO = Tl **
IF (T2 .LT. Tl) RATIO = T2 ^
Q AA
C *** SET LABEL END POINT ?*.
X2L = XI 4- RATIO* (X2-X1) ™
Y2L = Yl .+ RATIO* (Y2-Y1) ?C
p . AA
C *** CALCULATE LABEL ANGLE av
DX = X2L - XIL ?£
DY = Y2L - Y1L ^
ANG = ATAN2(DY,DX) ?C
Q AA
XL = XIL ^ 15°
YL = Y1L ^ 151
COSA = COS (ANG) ^
SINA = SIN (ANG) ?0
Q AX 1 b 4
C *** REVERSE EVERYTHING IF ANGLE IN QUADRANTS 2 OR 3 AX
IF (DX .GE. 0.) GO TO 90 ™
A 158
YL . Y2L AX 158
COSA = -COSA ?r;
SINA = -SINA J£
IF (DY .GE. 0.) ANG = ANG-3 . 14 15926536 AX
IF (DY .LT. 0.) ANG = ANG+3 . 14 15926536 AX 163
90 ANGD = ANG*180. /3.1415926536 ^
w
C *** LOCATE AND PLOT LABEL av
XL = XL + OFF*COSA f OFF*SINA ay
YL = YL 4- OFF*SINA - OFF*COSA ^
C *** CALL NUMBER TO PLOT THE LABEL ^
IDG=NCHR-2 AA
CALL NUMBER (XL, YL, CHRSZ , OZL, ANGD, IDG) ™
°FF THIS SEGMENT BY MEANS OF A PSUEDO REENTRY AX 174
— 0,
SKPSZ = DIST AX 175
NSV =0 AX 176
XI = X2L AX 177
Yl = Y2L AX 178
CALL PLOT (X1,Y1,3) AX. j7^
GO TO 30 AX 18°
AX 181
AX 182
<- ENTRY FOR IPEN = 1
C*******
" — """"""""""itxxKjrx*** * vr IOC
C AA -LOO
C *** PLOT THE SAVED VECTORS IF ANY av
100 IF (NSV .EQ. 0) RETURN AJ 1QO
DO 110 1=1,NSV AX 188
CALL PLOT (XSV(I),YSV(I),2) ^ ™*
AX-3
-------
c
110 CONTINUE AX 191
NSV = 0 AX 192
RETURN AX 193
AX 194
END AX 195-
AX-4
-------
SUBROUTINE WKRV1 ,v
C AY 2
AY "3
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO AY 4
C COMPUTE AN SPLINE UNDER TENSION PASSING THROUGH A SEQUENCE AY 5
C OF PAIRS (X(l)fY(l) ,X(N),Y\
C OF THE CURVE AT (X(1),Y(1)) AND (X(N),Y(N)), RESPEC- AY 26
C TIVELY. THESE QUANTITIES ARE IN RADIANS AND MEASURED AY 27
C COUNTER CLOCKWISE FROM THE POSITIVE X-AXIS. THE POSITIVE AY 28
C SENSE OF THE CURVE IS ASSUMED TO BE THAT MOVING FROM THE AY 29
C POINT 1 TO POINT N. AY tn
C XP,YP = ARRAYS OF LENGTH AT LEAST N, AY 31
C SIGMA = THE TENSION FACTOR. THIS IS NON-ZERO AND AY 32
C INDICATES THE CURVINESS DESIRED. IF SIGMA IS VERY AY 33
C LARGE (E.G. 50.) THE RESULTING CURVE IS VERY NEARLY A AY 34
C POLYGONAL LINE. A STANDARD VALUE FOR SIGMA IS 1. AY 35
\«r
C ON OUTPUT - AY 36
C NPTS,X,Y,SLP1,SLPN, AND SIGMA ARE UNALTERED, AY 38
C XP,YP CONTAIN INFORMATION ABOUT THE CURVATURE OF THE AY ^
C CURVE AT THE GIVEN NODE, £* .1
C S = THE POLYGONAL ARCLENGTH OF THE CURVE. AY \]_
c AY 42
COMMON /WKRV/ NPTS, NSLP, SLP1, SLPN, LSLP, TANGNT, S, AY 44
1 X(32),Y(32),XP(32),YP(32) AY 45
COMMON /CNTRL/ SIG,SIGMA,INFO,NPTO,TSRT,DTIM,Zl,Z2,DCON,EHC,EXN, AY 46
1 FLST,TLST AY d-?
COMMON /EXPVAL/ EXPMAX ** '
p Al 4 o
DIMENSION TEMP(32) AY 48
c AY 4 9
TEMAX=-9999.
AY 50
N = NPTS AY 51
NM1 = N-l AY 52
NP1 = N+l AY 53
DELX1 = X(2)-X(1) AY. II
DELY1 = Y(2)-Y(1)
DELS1 = SQRT(DELX1*DELX1+DELY1*DELY1) av 1%
DX1 = DELX1/DELS1 ?* „
DY1 = DELY1/DELS1 AY ^°
C *** DETERMINE SLOPES IF NECESSARY AV f?
C CHECK IF A LOOP ~* "
IF (NSLP .LT. 0) GO TO 80 ^ *
Ai b J
AY-1
-------
c
JMP = NSLP +1 AY 64
AY 65
C *** SPECIAL HANDLING FOR TWO POINT LINES AY 66
IF (N .EQ. 2) GO TO 40 AY 67
10 GO TO (20,30,20,90),JMP Ay 68
C
AY 69
C *** USE SECOND ORDER INTERPOLATION FOR ENDPOINT SLOPES AY 70
20 DELS2 = SQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2) AY 71
DELS12 = DELS1+DELS2 AY 72
Cl = -(DELS12+DELSD/DELS12/DELS1 AY 73
C2 = DELS12/DELS1/DELS2 AY 74
C3 = -DELS1/DELS12/DELS2 AY 75
SX = C1*X(1)+C2*X(2)+C3*X(3) AY 76
SY = C1*Y(1)+C2*Y(2)+C3*Y{3) . AY 77
SLP1 = ATAN2(SY,SX) AY 78
IF (NSLP .EQ. 2) GO TO 90 AY 79
C AY 80
30 DELNM1 = SQRT((X(N-2)-X(NMl))**2+(Y(N-2)-Y(NMl))**2) AY 81
DELN = SQRT((X(NM1)-X(N))**2+(Y(NM1)-Y(N))**2) AY 82
DELNN = DELNM1+DELN AY 83
Cl = (DELNN+DELN)/DELNN/DELN AY 84
C2 = -DELNN/DELN/DELNM1 AY 85
C3 = DELN/DELNN/DELNM1 AY 86
SX = C3*X(N-2)+C2*X(NMl)+Cl*X(N) AY 87
SY = C3*Y(N-2)+C2*Y(NM1)+C1*Y(N) AY 88
SLPN = ATAN2(SY,SX) AY 89
GO TO 90 AY 90
AY 91
C *** ONLY TWO POINTS SUPPLIED AY 92
40 GO TO (50,60,70,90),JMP AY 93
C AY 94
C *** NO SLOPES GIVEN — USE STRAIGHT LINE AY 95
C (ACTUALLY, THIS CASE SHOULD NEVER OCCUR) AY 96
50 XP(1) = 0. AY 97
XP(2) =0. AY 98
YP(1) = 0. AY 99
YP(2) = 0. AY 100
S = SQRT ( (X(2)-X(1))**2 + (Y(2)-Y(1))**2) AY 101
RETURN ' AY 102
C . AY 103
C *** FIRST SLOPE GIVEN AY 104
60 SLPN = ATAN2 (Y(2)-Y(1)-SLP1*(X(2)-X(1)), AY 105
1 X(2)-X(1)-SLP1MY(2)-Y<1))) AY 106
GO TO 90 AY 107
AY 108
C *** LAST SLOPE GIVEN AY 109
70 SLP1 = ATAN2 (Y(2)-Y(1)-SLPN*(X(2)-X(1)) , AY 110
1 X(2)-X(1)-SLPN*(Y(2)-Y(1))) AY 111
GO TO 90 AY 112
AY 113
C *** CLOSED LOOP — PERIODIC SPLINE — CALCULATE SLOPES AY 114
C FOR JOIN AY 115
80 DELN = SQRT((X(NM1)-X(N))**2+(Y(NM1)-Y(N))**2) AY 116
DELNN = DELSH-DELN AY 117
Cl = -DELS1/DELN/DELNN AY 118
C2 = (DELS1-DELN)/DELS1/DELN AY 119
C3 = DELN/DELNN/DELS1 AY 120
SX = C1*X(NM1)+C2*X(1)+C3*X{2) AY 121
SY = C1*Y(NM1)+C2*Y(1)+C3*Y(2) AY 122
IF (SX.EQ.O. .AND. SY.EQ.O.) SX = 1 AY 123
SLP1 = ATAN2(SY,SX) AY 124
SLPN = SLP1 AY 125
C AY 126
C *** SET BOTH SLOPES AY 127
AY-2
-------
90 SLPP1 = SLP1
c SLPPN - SLPN AY 129
C *** SET UP RIGHT HAND SIDES OF TRIDIAGONAL LINEAR SYSTEM FOR AY 131
C XP AND YP _ v
100 XP(1) = DXl-COS(SLPPl) AY. i«
YP(1) = DYl-SIN(SLPPl) av
TEMP(l) = DELS1 *A
S = DELS1
IF (N.EQ.2) GO TO 120 A*
DO 110 1-2, NM1 Av
DELX2 = X(I+1)-X(I) ?Y
DELY2 = Y(I+1)-Y(I) 7t
DELS2 = SQRT(DELX2*DELX2+DELY2*DELY2) AY
DX2 = DELX2/DELS2 av
DY2 = DELY2/DELS2 av
XP(I) = DX2-DX1 av
YP(I) = DY2-DY1 VY
TEMP (I) = DELS2 ^Y
TEMAX = AMAX1(TEMAX,TEMP(I)) av
DELX1 = DELX2 {£
DELY1 = DELY2 ^v
DELS1 = DELS2 ™
DX1 = DX2 ^
c °Y1 - DY2 AY 152
C *** ACCUMULATE POLYGONAL ARCLENGTH av
S =S+DELS1 ™
110 CONTINUE
120 XP(N) = COS (SLPPN) -DX1 AY
YP(N) = SIN (SLPPN) -DY1 ^
N^
C *** DENORMALIZE TENSION FACTOR ay
SIGMAP = ABS (SIGMA) 'FLOAT
-------
TEMPO = DIAGIN*SPDIAG AY 192
DIAG1 = DIAG2 Ay 193
140 CONTINUE AY 194
150 DIAGIN = 1./(DIAG1-SPDIAG*TEMP(NM1)) AY 195
XP(N) = DIAGIN* (XP(N)-SPDIAG*XP (NMD) AY 196
YP(N) = DIAGIN*(YP(N)-SPDIAG*YP(NM1)) AY 197
AY 198
C *** PERFORM BACK SUBSTITUTION AY 199
DO 160 1=2,N AY 200
IBAK = NP1-I AY 201
XP(IBAK) = XP{ IBAK) -TEMP (IBAK) *XP (IBAK-l-1) AY 202
YP(IBAK) = YP
-------
SUBROUTINE WKRV2 (T,XS,YS) a7 ,
SAVE ™ l
C AZ 2
AZ 3
C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE AZ 4
C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. THE SUBROUTINE AZ 5
C WKRV1 SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN AZ 6
C NECESSARY PARAMETERS. THE RESULTING CURVE HAS A PARAMETRIC AZ 7
C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE SPLINES UNDER AZ 8
C TENSION AND FUNCTIONS OF THE POLYGONAL ARCLENGTH PARAMETER. AZ 9
\*
C COMMON VARIABLES AND PARAMETERS ON INPUT— AZ 11
C T = A REAL VALUE OF ABSOLUTE VALUE LESS THAN OR AZ 12
C EQUAL TO 1. TO BE MAPPED TO A POINT ON THE CURVE. THE AZ 13
C SIGN OF T IS IGNORED AND THE INTERVAL (O.,l.) IS MAPPED AZ 14
C ONTO THE ENTIRE CURVE. IF T IS NEGATIVE THIS INDICATES AZ 15
C THAT THE SUBROUTINE HAS BEEN CALLED PREVIOUSLY (WITH ALL AZ 16
C OTHER INPUT VARIABLES UNALTERED) AND THAT THIS VALUE OF AZ 17
C T EXCEEDS THE PREVIOUS VALUE IN ABSOLUTE VALUE. WITH AZ 18
C SUCH INFORMATION THE SUBROUTINE IS ABLE TO MAP THE POINT AZ 19
C MUCH MORE RAPIDLY. THUS IF THE USER SEEKS TO MAP A AZ 20
C SEQUENCE OF POINTS ONTO THE SAME CURVE, EFFICIENCY IS AZ 21
C GAINED BY ORDERING THE VALUES INCREASING IN MAGNITUDE AZ 22
C AND SETTING THE SIGNS OF ALL BUT THE FIRST, NEGATIVE, AZ 23
C NPTS = THE NUMBER OF POINTS WHICH WERE INTERPOLATED AZ 24
C TO DETERMINE THE CURVE, C^ 25
C X,Y = ARRAYS CONTAINING THE X- AND Y-COORDINATES A7 9fi
C OF THE INTERPOLATED POINTS, at 27
C XP,YP = THE ARRAYS OUTPUT FROM WKRV2 CONTAINING- A7 9P
C CURVATURE INFORMATION, £7 90
C S = THE POLYGONAL ARCLENGTH OF THE CURVE AZ 30
C SIGMA = THE TENSION FACTOR (ITS SIGN IS IGNORED). AZ 31
f* TCTT5 — 'HT7!TTl^rv¥TT-r**r»-^«_.«,___ *"ltl J 1.
C LSLP = A FLAG WHICH IF >0 REQUESTS THE SLOPE A7 39
AZ 33
W
C TANGNT = THE SLOPE REQUESTED BY LSLP
C THE PARAMETERS NPTS,, X, Y, XP, YP , S, AND SIGMA SHOULD BE INPUT AZ 35
,
C UNALTERED FROM THE OUTPUT OF WKRV1
Q '
C ON OUTPUT — AZ 37
C XS,YS = THE X- AND Y-CO
C POINT ON THE CURVE.
C
C XS,YS = THE X- AND Y-COORDINATES OF THE IMAGE A7 3Q
C POINT ON THE CURVE. "? ^
C T,NPTS,X,Y,XP,YP,S, AND SIGMA ARE UNALTERED. AZ 41
COMMON /WKRV/ NPTS, NSLP , SLP 1, SLPN, LSLP, TANGNT, S, AZ 43
1 X(32),Y(32),XP(32),YP<32) Az 44
COMMON /CNTRL/ SIG, SIGMA, INFO, NPTO, TSRT, DTIM, Zl, Z2, DCON, EHC, EXN, AZ 45
c l FLST,TLST AZ ^
N = NPTS AZ 47
c AZ 48
C *** DENORMALIZE SIGMA AZ, ^
SIGMAP = ABS (SIGMA) *FLOAT(N-1)/S *~ °
***
STRETCH UNIT INTERVAL INTO ARCLENGTH DISTANCE A7
TN = ABS (T*S)
D 1
c AZ 54
c "*
IF (T.LT.O.) GO TO 10 0
II = 2
XS = X(l) AZ 59
YS = Y(l) AZ 60
SUM =0. AZ 61
IF (T.LT.O.} RETURN AZ. !f
Q AZ 63
AZ 64
AZ-1
-------
C *** DETERMINE INTO WHICH SEGMENT TN IS MAPPED AZ 65
10 DO 30 I=IlfN AZ 66
DELX = Xd)-X(I-l) AZ 67
DELY = Y(I)-YU-l) AZ 68
DELS = SQRT(DELX*DELX+DELY*DELY) AZ 69
IF (SUM+DELS-TN) 20,40,40 AZ 70
20 SUM = SUM+DELS AZ 71
30 CONTINUE AZ 72
C AZ 73
C *** IF ABS(T) IS GREATER THAN 1., RETURN TERMINAL POINT ON AZ 74
C CURVE AZ 75
C AZ 76
XS = X(N) AZ 77
YS = Y(N) AZ 78
RETURN AZ 79
C A2 go
C *** SET UP AND PERFORM INTERPOLATION AZ 81
40 DELI = TN-SUM AZ 82
DEL2 = DELS-DELI AZ 83
EXPS1 = EXP(SIGMAP*DEL1) AZ 84
SINHD1 = .5MEXPS1-1./EXPS1) AZ 85
EXPS2 = EXP(SIGMAP*DEL2) AZ 86
SINHD2 = .5MEXPS2-1./EXPS2) AZ 87
EXPS = EXPS1*EXPS2 AZ 88
SINHS = .5MEXPS-1./EXPS) ' AZ 89
XS = (XP(I>*SINHD1+XP(I-1)*SINHD2)/SINHS+ AZ 90
1 «X(I)-XP(I))*DEL1+(X(I-1)-XP
-------
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE AXES (X,Y,FIRSTV, FINALV, SCALE, TSTEP, ASTEP, NDEC, ANGLE,
1 v*D , NCHAR , LABEL )
*** SAI SUBROUTINE AXES
GW LUNDBERG/SAI DEC 76
X,Y = COORDINATES IN INCHES OF AXIS LINE STARTING
POINT
FIRSTV = STARTING VALUE FOR THE AXIS
FINALV = ENDING VALUE FOR THE AXIS
SCALE = INCHES/UNIT FOR FIRSTV, FINALV, TSTEP, ASTEP
TSTEP = STEP SIZE FOR TICS
ASTEP = STEP SIZE FOR LABELED TICS
NDEC = FORMAT FOR LABELS — SEE SUBROUTINE NUMBER
ANGLE = ANGLE OF AXIS IN DEGRES FROM HORIZONTAL
IBCD = THE AXIS TITLE AS ARRAY OR HOLLERITH STRING
NCHAR = NUMBER OF CHARACTERS IN TITLE
) 0, TIC. MARKS, ANNOTATION AND TITLE PLOTTED ON
CLOCKWISE SIDE OF AXIS LINE
{ Of ON COUNTER CLOCKWISE SIDE
THIS ROUTINE WAS WRITTEN FOR A MATRIX PLOTTER -- IT DOES
NOT OPTIMIZE PEN MOVEMENTS. THE ROUTINE SHOULD BE MACHINE
INDEPENDENT
*** FOLLOWING ARE ADJUSTABLE — IF LABEL > 0, ALL TICS ARE
LABELED, IF LABEL = 0, THE LAST TIC IS NOT LABELED,
IF LABEL < 0, THE FIRST AND LAST ARE NOT LABELED
*** DEFINE VARIOUS CHARACTER SIZES
SAVE
COMMON /PLTVEC/ HCT {20} , OT (20) , NH, OHC, HCG, PLTGRD, OXN, XNG, HC1 , XN1
1 TICSIZ,DIGSIZ,CHRSIZ,IPLDEV
INTEGER IBCD (3)
CHARACTER*24 IBCD
*** STEP 1 -- DRAW AXIS AND TIC MARKS
*** MOVE PEN TO START OF AXIS
XO=X
YO=Y
CALL PLOT (XO,YO,3l
*** LOCATE THE OTHER END AND DRAW AXIS
COSA=COS (ANGLE *0 . 0174 532 94)
SINA=SIN (ANGLE*0 .017453294 )
AXLEN= (FINAL V-FIRSTV) * SCALE
X1=XO+AXLEN*COSA
Y1=YO+AXLEN*SINA
CALL PLOT (X1,Y1,2)
*** ADD THE TIC MARKS ON WRONG SIDE OF AXIS
POS=FLOAT(ISIGN(1, NCHAR) )
IF (TSTEP. EQ.O.) GO TO 20
NTIC=(FINALV-FIRSTV)/TSTEP+1 5
DO 10 J=1,NTIC
*** MOVE PEN TO START OF TIC
X1=XO+FLOAT(J-1) *TSTEP*SCALE*COSA
Y1=YO+FLOAT(J-1) *TSTEP*SCALE*SINA
CALL PLOT (X1,Y1,3)
IBBA
BA
BA
BA
Of\
BA
BA
BA
BA
RA
an
RA
±m
BA
RA
on
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
RA
Of\
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
BA
DA
BA
n A
Dn
D A
BA
BA
BA
BA
BA
BA
n TV
BA
BA
O A
BA
BA
BA
T} TV
BA
D A
BA
D A
BA
BA
BA
1
2
3
4
T
5
6
7
8
i n
X U
11
X X
1 "7
1 J
14
15
16
X w
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
^
35
35A
36
37
38
39
40
41
42
43
44
A C.
'i J
A C
-------
C *** DRAW A TIC NORMAL TO AXIS BA 64
X1=X1+TICSIZ*POS*SINA BA 65
Y1=Y1-TICSIZ*POS*COSA BA 66
CALL PLOT (X1,Y1,2) BA 67
10 CONTINUE BA 6Q
C BA 69
C *** STEP 2 — SET IN LABELED TICS ON CORRECT SIDE OF AXIS BA 70
c BA 71
BA 72
20 IF (ASTEP . EQ . 0 . ) GO TO 50 BA 73
NTIC=(FINALV-FIRSTV)/ASTEP+1.5 BA 74
NFRST=1 BA 75
NLST=NTIC BA 76
IF ( LABEL. LE.O) NLST=NLST-1 BA 77
IF ( LABEL. LT.O) NFRST=NFRST+1 BA 78
DO 30 J=NFRST,NLST BA 79
X1=XO+FLOAT(J-1)*ASTEP*SCALE*COSA BA 80
Y1=YO+FLOAT(J-1)*ASTEP*SCALE*SINA BA 81
CALL PLOT (X1,Y1,3) BA 82
C BA 83
X1=X1-TICSIZ*POS*SINA BA 84
Y1=Y1+TICSIZ*POS*COSA BA 85
CALL PLOT (X1,Y1,2) BA Q6
30 CONTINUE - BA 87
C BA 88
C *** STEP 3 ~ ANNOTATE THE TIC MARKS BA 89
c BA go
BA 9 1
C *** DETERMINE PERPENDICULAR OFFSET TO BOTTOM OF CHARACTER BA 92
OFFSET=TICSIZ+0.03 BA 93
IF (POS.NE.1.0) OFFSET=OFFSET+DIGSIZ BA 94
BA 95
C *** CALCULATE LOCATION OF FIRST CHARACTER BA qg
XO=XO-DIGSIZ*COSA BA 97
YO=YO-DIGSIZ*SINA BA 9Q
XO=XO-OFFSET*POS*SINA BA 99
YO=YO+OFFSET*POS*COSA BA 100
C *** ANNOTATE THE TIC MARKS RA
NFRST=1
NLAST=NTIC BA
IF (LABEL. LE.O) NLAST=NLAST-1 BA 105
IF (LABEL. LT.O) NFRST=NFRST+1 " BA 106
DO 40 J=NFRST,NLAST BA 1Q7
? BA 108
C *** GET FLOATING POINT VALUE OF ANNOTATION BA 1Q9
FPN=FIRSTV+FLOAT(J-1)*ASTEP BA 110
^ BA 1 1 1
C *** GET LOCATION AND PLOT FPN BA 112
X1=XO+FLOAT(J-1) *ASTEP*SCALE*COSA BA 113
Y1=YO+FLOAT(J-1) *ASTEP*SCALE*SINA BA 114
CALL NUMBER (XI, Yl , DIGSIZ, FPN, ANGLE, NDEC) BA 115
c 4° CONTINUE BA U6
C *** STEP 4 — ADD AXIS TITLE BA 118
c BA iig
BA i p n
50 IF (NCHAR.EQ.O) GO TO 60 BA I2l
C *** SET TITLE OFFSET — DISTANCE FROM AXIS TO CHARACTERS BA 122
OFFSET=TICSIZ+DIGSIZ+0.10 BA 123
IF (NCHAR.LT.O) OFFSET=OFFSET+CHRSIZ BA
C *** CALCULATE TITLE SIZE BA
TSIZ=CHRSIZ*FLOAT(IABS(NCHAR) ) BA 127
BA-2
-------
°FFSET FR°M BEGINNING OF AXIS TO FIRST CHARACTER BA 129
(AXLEN-TSIZ) BA
*** CALCULATE LOCATION OF FIRST CHARACTER AND PLOT TITLE BA 132
XO=X+OFF*COSA n_
YO=Y+OFF*SINA ?? "3
XO-XO-OFFSET*POS*SINA ^ :„
YO-YO+OFFSET*POS*COSA na ,tl
NCCAR=IABS(NCHAR) fT ""
CALL SYMBOL (XO, YC), CHRSIZ, IBCD, IDUM, ANGLE, NCCAR) BA 138
FINISHED ^A 139
60 RETURN . BA 140
END BA 141
BA 142-
BA-3
-------
SUBROUTINE FRAME (X,Y,FRSTX,FINX,SIZX,TICX,STEPX,NDECX,FRSTY,FINY
1SIZY,TICY,STEPY,NDECY,LBLBOT,NB,LBLLFT,NL,LBLTOP,NT,LBLRGT,NR)
*** PURPOSE — PREPARES AN ANNOTATED FOUR SIDED FRAME
WITH LOWER LEFT CORNER AT (X,Y)
GWL/SAI MARCH 77
SEE SUBROUTINE AXES FOR DESCRIPTION OF ARGUMENTS
SAVE
COMMON /PLTVEC/ HCT(20),OT(20),NH,OHC,HCG,PLTGRD,OXN,XNG,HCC,XNC,
1 TICZ,DIGZ,CHRZ,IPLDEV
DIMENSION LBLTOP{6),LBLRGT(6)
CHARACTER*]. LBLRGT, LBLTOP
CHARACTER*12 LBLLFT, LBLBOT
*** CALCULATE THE AXES LENGTHS
XLEN=(FINX-FRSTX)*SIZX
YLEN=(FINY-FRSTY)*SIZY
*** PLACE GRIDDED LINES ON PLOT
IF (ABS(PLTGRD).EQ.O.) GO TO 80
IF (PLTGRD.LT.0.) GO TO 50
CALL NEWPEM (2)
STINC=(STEPY/10.)*SIZY
ILP=FINY/STEPY+.005
ILP=ILP*10-1
STVAL=STINC
J=l
DO 20 1=1,ILP
IF (J.EQ.2) GO TO 10
CALL PLOT (X,STVAL,3)
CALL PLOT (XLEN,STVAL,2)
STVAL=STVAL+STINC
J=2
GO TO 20
10 CALL PLOT (XLEN,STVAL,3)
CALL PLOT (X,STVAL,. 2)
STVAL=STVAL+STINC
J=l
20 CONTINUE
STINC=(STEPX/10.)*SIZX
ILP=FINX/STEPX+.005
ILP=ILP*10-1
STVAL=STINC
J=l
DO 40 1=1,ILP
IF (J.EQ.2) GO TO 30
CALL PLOT (STVAL,Y,3)
CALL PLOT (STVAL,YLEN,2)
STVAL^STVAL+STINC
J=2
GO TO 40
30 CALL PLOT (STVAL,YLEN,3)
CALL PLOT (STVAL,Y,2)
STVAL=STVAL+STINC
J=l
40 CONTINUE
CALL NEWPEN (1)
GO TO 80
PLOT GRIDDED LINES WITH MATRIX PLOTTER
,BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
BB
1
2
3
4
5
6
7
8
9
10
11
12
13
13A
13B
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
BB-1
-------
50 IPLT=IFIX(PLTGRD) nn „
CALL NEWPEN (IPLT) Jn c/
STINC={STEPY/10.)*SIZY ^ f*
ILP=IFIX(FINY/STEPY+0.005)*10-1 nn lc
STVAL=STINC BB °°
DO 60 1=1,ILP II I1
IF (MOD(I,10).EQ.O) CALL NEWPEN (IPLT+1) nn II
CALL PLOT (X+0.01,STVAL,3) £n ™
CALL PLOT (XLEN,STVAL,2) ** .1°
IF (MOD(I,10).EQ.O) CALL NEWPEN (IPLT) nn 4i
STVAL=STVAL+STINC „ '*
60 CONTINUE BB 73
STINC=(STEPX/10.)*SIZX ^n ^l
ILP=IFIX(FINX/STEPX+0.005)*10-1 nn nl
STVAL=STINC BB 76
DO 70 1=1,ILP !? ;7
IF (MOD(I,10).EQ.O) CALL NEWPEN (IPLT+1) nn -70
CALL PLOT (STVAL,Y-0.02,3) ^ II
CALL PLOT (STVAL,Y,,3) ^ o°
CALL PLOT (STVAL,YLEN,2) ^ ",
IF (MOD(I,10).EQ.O) CALL NEWPEN (IPLT) nn oo
STVAL=STVAL+STINC BB ^3
70 CONTINUE BB 84
CALL NEWPEN (0) !? 85
80 CONTINUE BB 86
c BB 87
C *** PLOT THE FOUR SIDES WITH ANNOTATIONS nn II
) BB 90
,.,f BB 91
AXES (Y+yiiNRTjB 92
•*• •*• I
BB 9"3
CALL AXES (X+XLEN,Y,FRSTY,FINY,SIZY,TICY,STEPY,NDECY,90.,LBLRGT,-NBB 94
c 1R'~1) BB 95
RETURN BB 96
END BB 97
BB 98
BB-2
-------
SUBROUTINE OPENA
OPEN SUBROUTINE FOR OZIPM4
CHARACTER*80 IPATH
CHARACTER*! IAfIA1
OPEN INPUT AND OUTPUT FILES FOR EKMA/OZIPM4
10 CONTINUE
READ (14,100,END=99) IA, IA1, IPATH
IUNIT = 0
IF (IA .EQ. '!' .OR. IA .EQ. 'I') IUNIT = 7
IF (IA .EQ. 'o' .OR. IA .EQ. '0') IUNIT = 10
IF (IA .EQ. 'p' .OR. IA .EQ. 'P') IUNIT = 8
IF {IA .EQ. 'r' .OR. IA .EQ. 'R') IUNIT = 9
IF (IA .EQ. 'e' .OR. IA..EQ. 'E') IUNIT = 11
IF (IA .EQ. 'm' .OR. IA .EQ. 'M') IUNIT = 54
CHECK FOR CORRECT INPUT STRUCTURE
IF (IA1 .NE. '=') IUNIT = 0
IF {IUNIT .NE. 0) GO TO 20
STOP
20 CONTINUE
IF (IUNIT .NE. 54) OPEN (IUNIT, FILE = IPATH)
THE FOLLOWING LINE IS THE ONLY EXTENSION TO FORTRAN 77 STANDARDS
IN THIS SOURCE CODE. IN ORDER TO CREATE A METAFILE FOR PLOTTING
PURPOSES, THE LINE WILL NEED TO BE UNCOMMENTED AND POSSIBLY
REWRITTEN TO MEET THE SPECIFICATIONS OF YOUR COMPUTER SYSTEM
IF (IUNIT .EQ. 54) OPEN (IUNIT, FILE = IPATH, FORM = 'BINARY')
GO TO 10
99 RETURN
10-0 FORMAT (A, A, 8OA)
END
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
BC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
BC-1
-------
SUBROUTINE PLOTS (11,12,13) nn i
RETURN °" ;
END BD 3
SUBROUTINE NEWPEN (IPLT) nn 4
RETURN
BD
END
SUBROUTINE PLOT (XXZE, YYZE, IP1)
RETURN „
END Bg
SUBROUTINE SYMBOL (ORGX, ORGY, CHRZ, ITL1, IDUMr FPS1, IS1) BD 10
RETURN " ^
END BD 12
SUBROUTINE NUMBER {XL, YL, CHRSZ, OZL, ANGD, IDG) BD it
RETURN on ,,
% II
BD-1
-------
C. tfr.V~T> ACCEF,r>'O\ NO.
4. TIT L.I: AMIIi SUBTITLE
ts «;"•'<; Manual for OZIPM-4 (Ozone Isopleth Plotting
with Optional Mechanisms/Version 4): Volume 2:
Computer Code
j£. •= -EPC R f DA'
6. I'E.RFORM'NG ORGANIZATION CODE
7. AUTHOR(S)
8. PERFORMING ORGANIZATION REPORT NO
EPA-450/4-89-009b
9. PERFORMING ORGANIZATION NAME AND ADDRESS
U. S. Environmental Protection Agency
Office of Air Quality Planning and Standards
Research Triangle Park, NC 27711
10. PROGRAM ELEMENT NO.
11. CONTRACT/GRANT NO.
12. SPONSORING AGENCY NAME AND ADDRESS
13. TYPE OF REPORT AND PERIOD COVERED
Final
14. SPONSORING AGENCY CODE
15. SUPPLEMENTARY NOTES
EPA Contact: Keith Baugues
16. ABSTRACT
This document lists the OZIPM-4 program and describes modifications necessary
to run the program on several different computers.
17.
KEY WORDS AND DOCUMENT ANALYSIS
a.
DESCRIPTORS
b.lDENTIFIERS/OPEN ENDED TERMS C. COSATI Field/Group
Ozone
Photochemical modeling
VOC control strategies
18. DISTRIBUTION STATEMENT
Unlimited
19. SECURITY CLASS (This Report)
Unclassified
20. SECURITY CLASS (This page/
Unclassified
21. NO. OF PAGES
173
22. PRICE
EPA Form 2220-1 (Rev. 4-77) PREVIOUS EDI TION is OBSOLETE
-------
------- |