United States Atmospheric Sciences
Environmental Protection Research Laboratory
Agency Research Triangle Park NC 27711
Research and Development November 1987
PROJECT REPORT
USER'S GUIDE TO THE
COMPLEX TERRAIN DISPERSION MODEL
VOLUME 2:
MODEL CODE LISTINGS
-------
USER'S GUIDE TO THE COMPLEX TERRAIN DISPERSION MODEL
VOLUME 2: MODEL CODE LISTINGS
by
Robert J. Paine1
David G. Strimaitis^
Michael G. Dennis1
Robert J. Yamartino^
Michael T. Mills1
Elizabeth M. Insley^
1ERT, Inc.
696 Virginia Road, Concord, MA 01742
2Sigma Research Corp.
394 Lowell St., Suite 12, Lexington, MA 02173
Contract No. 68-02-3421
Project Officer
Peter L. Finkelstein
Meteorology Division
Atmospheric Sciences Research Laboratory
- ATMOSPHERIC SCIENCES RESEARCH LABORATORY
OFFICE OF RESEARCH AND DEVELOPMENT
U.S. ENVIRONMENTAL PROTECTION AGENCY
RESEARCH TRIANGLE PARK, NORTH CAROLINA 27711
-------
NOTICE
The information in this document has been funded by the United
States Environmental Protection Agency Under Csontract No. 68-02-3421
to ERT, Inc. It has been subjected to the Agency's peer and admini-
strative review, and it has been approved for publication as an EPA
document. Mention of trade names or commercial products does not
constitute endorsement or recommendation for use.
n
-------
CONTENTS
APPENDICES
C. CTDM CODE LISTINGS 1
D. RECEPTOR GENERATOR CODE LISTINGS 151
E. SETUP PROGRAM CODE LISTINGS 168
F. GRAPHICAL CONCENTRATION DISPLAY CODE LISTINGS 238
ill
-------
APPENDIX C
CTDM CODE LISTINGS
-------
APPENDIX C
CTDM CODE LISTINGS
Code listings for CTDM, the main program, and its 50 subroutines
are included in this appendix. The routines are listed in alphabetical
order following the main program:
CTDM LINES
ANGINT LSTAB
BULKFR LVDF
DELWD MAP
ERT MIX
FLAT MUNU
FLOW PAGE
GETDTH PATH
GETSV PICK4
GETSW PLAVG
GETTA PSRCE
GETUV RDSFC
GETWD SEQMOD
GETWS SIGB
HCRIT . SPEED
HILHGT SRISE
HILROT SUN
INPAR TOPN
INPEMS TERAX
INPREC URISE
INPSOR UVWD
INPTER WRAP
INPTOW WRAPIN
KLOSE WRITIT
LIFT XINTRP
LIFTIN
The CTDM code listings are followed by several INCLUDE files,
containing PARAMETER assignments and COMMON blocks, that are used
throughout the CTDM code. Besides one file containing the PARAMETER
assignments ("PARAMS.INC"), the order of COMMON blocks listed is:
CONST RECEPT
HEAD - SFCMET
HILL STACK
10 STACKS
PARAMS TIME
PASL TOP
PASVAL TOWER
PASW VARS
PROFIL
-------
CTDM FORTRAN Code Listings
-------
PROGRAM CTDM
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****************tf***************************************************
C
INCLUDE 'PARAMS.INC'
INCLUDE 'IO.CMN'
INCLUDE 'HEAD.CMN'
THE COMPLEX TERRAIN DISPERSION MODEL (CTDM)
PURPOSE:
THIS IS THE MAIN PROGRAM OF THE COMPLEX TERRAIN DISPERSION MODEL
THIS ROUTINE OPENS INPUT AND OUTPUT FILES AND CALLS SUBROUTINES
THAT HANDLE PROGRAM OPTIONS, SOURCE, RECEPTOR, AND TERRAIN
DESCRIPTIONS; A MAP OF SOURCES, RECEPTORS, AND TERRAIN;
AND INITIATION OF SEQUENTIAL MODELING.
LIMITATIONS:
TITLE FOR THIS RUN IS LIMITED TO 80 CHARACTERS.
PROGRAM OPTIONS INPUT FILE IS OPENED TO UNIT 5.
OUTPUT LISTING FILE IS OPENED TO UNIT 6.
NOTE: DEFAULT I/O UNIT NUMBERS ARE ASSIGNED IN THE MAIN
PROGRAM AND CAN BE CHANGED HERE.
COMMON BLOCKS USED: HEAD,IO,PARAMS
INPUT FROM UNIT 5: (CTDM.IN)
TITLE FOR THIS RUN
OUTPUT: NONE
EXTERNAL ROUTINES CALLED:
PAGE - STARTS A NEW PRINTED PAGE
INPAR - READS AND PRINTS PROGRAM PARAMETERS AND SWITCHES
INPSOR - READS AND PRINTS STACK INFORMATION
INPREC - READS AND PRINTS RECEPTOR INFORMATION
INPTOW - READS METEOROLOGICAL TOWER COORDINATES
INPTER - READS TERRAIN DATA
MAP - PRINTS A MAP LOCATING STACKS, RECEPTORS, AND TERRAIN
SEQMOD - INITIATES SEQENTIAL MODELING CALCULATIONS
INCLUDE
1PARAMS.CMN1
C
C
C
C
C
DEFINE LOCAL VARIABLES
INTEGER YES
DATA YES/I/
DEFAULT UNIT NUMBERS (IO.CMN)
INTERR - 2
INEMIS - 3
INREC - 4
IN - 5
IOUT - 6
INSFC - 7
IOCONC - 9
INPROF - 11
CTD00010
CTD00020
CTDOOQ30
CTD00040
CTD00050
CTD00060
CTD00070
CTD00080
CTD00090
.CTD00100
CTD00110
CTD00120
CTD00130
CTD00140
CTD00150
CTD00160
CTD00170
CTD00180
CTD00190
CTD00200
CTD00210
CTD00220
CTDOCI230
CTD00240
CTD00250
CTD00260
CTD00270
CTDOCI280
CTD00290
CTD00300
CTD00310
CTD00320
CTD00330
CTDOQ349-
CTD00350
CTD00360
CTD00370
CTD00380
CTD00390
CTD00400
CTD00410
CTD00420
CTD00430
CTD00440
CTD00450
CTD00460
CTD00470
CTD00480
CTD00490
CTD00500
CTD00510
CTD00520
CTD00530
CTD00540
CTD00550
CTD00560
CTD00570
CTD00580
CTD00590
CTD00600
-------
c
c
C-*-*l
c
c
c
c
c
c
c
c
c
c
c
1
2
c
c
c
c
c
5010
c
NPAGE = 0
OPEN ( IN , FILE- ' CTDM . IN ' , STATUS- ' OLD ' )
OPEN(IOUT, FILE- 'CTDM. OUT1, STATUS- ' UNKNOWN ' )
CARRIAGECONTROL- ' FORTRAN ' )
READ LINE 1 OF "CTDM. IN"
READ( INr 5010) TITLE
CALL PAGE (YES)
READ LINES 2 , 3 OF "CTDM. IN"
CALL INPAR
READ LINE 4 OF "CTDM. IN"
CALL INPTOW
READ LINE 5 OF "CTDM. IN"
CALL INPSOR
IF(IEMIS .EQ. YES) OPEN(INEMIS, FILE- ' EMISSION ', STATUS- 'OLD1 )
OPEN ( INREC , FILE- ' RECEPTOR ' , STATUS- ' OLD ' )
CALL INPREC
CLOSE (INREC)
OPEN ( INTERR , FILE- ' TERRAIN ' , STATUS- ' OLD ' )
CALL INPTER
CLOSE (INTERR)
OPEN ( INS FC , FI LE- ' SURFACE ' , STATUS- ' OLD • )
OPEN(INPROF, FILE- ' PROFILE ', STATUS- ' OLD ')
IF(ICONC .EQ. 1) THEN
OPEN ( IOCONC , FILE- ' CONG ' ,
FORM- • UNFORMATTED ' ,
STATUS- ' n«w ')
ELSE IF(IABS(ICONC) .GT. 1 ) THEN
OPEN ( IOCONC , FILE- ' CONC ' , STATUS- ' new ' )
ENDIF
CALL MAP
CALL SEQMOD
STOP
FORMAT ( 2 OA4)
END
CTD00610
CTD00620
CTD00630
CTD00640
CTD00650
CTD00660
CTD00670
CTD00680
CTD00690
CTD00700
CTD00710
CTD00720
CTD00730
CTD00740
CTD00750
CTD00760
CTD00770
CTD00780
CTD00790
CTD00800
CTD00810
CTD00820
CTD00830
CTD00840
CTD00850
CTD00860
CTD00870
CTD00880
CTD00890
CTD00900
CTD00910
CTD00920
CTD00930
CTD0094«-
CTD00950
CTD00960
CTD00970
CTD00980
CTD00990
CTD01000
CTD01010
CTD01020
CTD01030
CTD01040
CTD01050
CTD01060
CTD01070
CTD01080
CTD01090
-------
REAL FUNCTION ANGINT( Al , Bl, TH1, XI, A2 , B2 , TH2 , X2 , X )
C PURPOSE: INTERPOLATE BETWEEN TWO ELLIPSE ORIENTATION ANGLES. THE
C VALUES ARE SCALED BY THE ECCENTRICITY OF THE ELLIPSES.
C
C LIMITATIONS: NONE
C
C ARGUMENTS:
C PASSED
C Al, Bl REAL MAJOR AND MINOR AXIS LENGTHS OF LOWER ELLIPSE
C TH1 REAL ORIENTATION ANGLE [DEC] OF LOWER ELLIPSE
C XI REAL HEIGHT OF LOWER ELLIPSE
C A2, B2 REAL MAJOR AND MINOR AXIS LENGTHS OF UPPER ELLIPSE
C TH2 REAL ORIENTATION ANGLE [DEC] OF UPPER ELLIPSE
C X2 REAL HEIGHT OF UPPER ELLIPSE
C X REAL HEIGHT AT WHICH ANGLE IS DESIRED
C RETURNED FUNCTION VALUE
C ANGINT REAL INTERPOLATED ANGLE [DEC] BETWEEN Al AND A2
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES:
C DELWD - FUNCTION RETURNS DIFFERENCE BETWEEN TWO WIND DIRECTIONS
C UVWD - FUNCTION WHICH RETURNS METEOROLOGICAL ANGLE GIVEN U, V
C
C COMMON BLOCKS: NONE
C
C
C DEFINE ARGUMENTS
REAL Al, Bl, TH1, XI, A2 , B2 , TH2 , X2 , X
C DEFINE LOCAL VARIABLES
REAL DA, DX, DX1, DX2, El, E2 , Tl, T2 , D2R
DATA D2R/0.01745329/
C START
ARG1 - A1*A1 - B1*B1
IF(ARG1 .LT. 0.0) ARG1 -0.0
ARG2 -• A2*A2 - B2*B2
IF (ARC 2 .LT. 0.0) ARG2 -0.0
C
C ECCENTRICITIES ARE DEFINED IN EQN 7 OF THE TERRAIN PREPROCESSOR
C USER'S GUIDE
C
El - SQRT(ARGl) / Al
E2 - SQRT(ARG2) / A2
DX - X2 - XI
DX1 - X - XI
DX2 - X2 - X
Tl - TH1 * D2R
T2 - TH2 * D2R
C
C SEE EQN 11 OF THE TERRAIN PREPROCESSOR USER'S GUIDE
C
U - (DX2 * El * SIN(Tl) + DX1 * E2 * SIN(T2)) / DX
V - (DX2 * El * COS(Tl) + DX1 * E2 * COS(T2)) / DX
ANGINT - UVWD(U,V)
C CHECK FOR U-V-0
IF( ANGINT .LT. 0.0 ) THEN
DA - DELWD ( TH1, TH2 )
IF( DX .NE. 0.0 ) THEN
ANG00010
ANG00030
ANG00040
ANG00050
ANG00060
ANG00070
ANG00080
ANG00090
ANG00100
ANG00110
ANG00120
ANG00130
ANG00140
ANG00150
ANG00160
ANG00170
ANG00180
ANG00190
ANG00200
ANG00210
ANG00220
ANG00230
ANG00240
ANGOCI250
ANGOCI260
ANG00270
A wf* n o *5 a r\
•ATiuUUZoU
ANG00290
ANG00300
ANG00310
ANG00320
ANG00330
ANG0034er
ANG00350
ANG00360
ANG00370
ANG00380
ANG00390
ANG00400
ANG00410
ANG00420
ANG00430
ANG00440
ANG00450
ANG00460
ANG00470
ANG00480
ANG00490
ANG00500
ANG00510
ANG00520
ANG00530
ANG00540
ANG00550
ANG00560
ANG00570
ANG00580
ANGOOS90
ANG00600
-------
ANGINT » TH1 + DX1*DA/DX ANG00610
ELSE ANG00620
ANGINT - TH1 + DA*0.5 ANG00630
ENDIF ANG00640
IF( ANGINT .LT. 0.0 ) THEN ANG00650
ANGINT - 360.0 + ANGINT ANG00660
ELSE IF( ANGINT .GT. 360.0 ) THEN ANG00670
ANGINT = ANGINT - 360.0 ANG00680
ENDIF ANG00690
ENDIF . ANG00700
RETURN ANG00710
END ANG00720
-------
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
REAL FUNCTION BULKFR( HTOP, HC)
PURPOSE: THIS ROUTINE COMPUTES THE BULK FROUDE NUMBER IN THE
HEIGHT INTERVAL BETWEEN HC AND 1.5 TIMES THE CUT-OFF
HILL HEIGHT.
ARGUMENTS
PASSED:
HTOP REAL HEIGHT OF HILL TOP ABOVE TOWER BASE (M)
HC REAL DIVIDING STREAMLINE HEIGHT ABOVE TOWER
BASE (M)
RETURNED AS A FUNCTION VALUE:
BULKFR REAL BULK FROUDE NUMBER IN THE HEIGHT INTERVAL
BFR00010
BFR00030
BFR00040
BFR00050
BFR00060
BFR00070
BFR00080
BFR00090
BFR00100
BFR00110
BFR00120
BFR00130
BFR00140
BETWEEN HC AND 1.5 TIMES THE CUT-OFF HILL HEIGHTBFR00150
CALLING ROUTINES: SEQMOD
EXTERNAL ROUTINES: GETTA GETWS
COMMON BLOCKS: NONE
NUMBER OF EQUAL LAYERS THE HC-TOP LAYER IS DIVIDED INTO
PARAMETER ( NLAYER - 10)
DEFINE ARGUMENTS
REAL HTOP, HC
DEFINE LOCAL VARIABLES
REAL BVF, DELT, DELZ, DEPTH, DTHETA, HCUTOF, TAMID, TOP,
* WSAVG, WSSUM, ZMID
INTEGER I
HCUTOF - HTOP - HC
TOP - HC + 1.5 * HCUTOF
OBTAIN AN AVERAGE WIND SPEED FROM HC TO TOP BY DIVIDING THAT
LAYER INTO NLAYER EQUAL HEIGHTS. THE INTERPOLATED WIND SPEEDS
BFR00160
BFR00170
BFR00180
BFR00190
BFR00200
BFR00210
BFR00220
BFR00240
BFR00250
BFR00260
BFR00270
BFR00280
BFR00290
BFR00300
BFR00310
BFR00320
BFR00330
BFR00348-
BFR00350
BFR00360
BFROQ370
BFR00380
BFR00390
BFR00400
C
c
c
100
c
c
c
c
c
AT THE MIDPOINTS OF THE HEIGHT SEGMENTS ARE AVERAGED TO
THE AVERAGE WIND SPEED.
WSSUM >
DEPTH •
DELZ -
DO
> 0.
• TOP - HC
DEPTH * 0.
100 I - 1, NLAYER
ZMID - HC + (1-0.5) * DELZ
WSSUM - WSSUM + GETWS(ZMID)
CONTINUE
WSAVG - WSSUM * (1.0/FLOAT(NLAYER))
OBTAIN THE TEMPERATURE DIFFERENCE THROUGH THE LAYER AND THE
TEMPERATURE AT THE MIDPOINT OF THE LAYER.
DELT - GETTA(TOP) - GETTA(HC)
ZMID - (HC + TOP) * 0.5
DTHETA - DELT/DEPTH + 0.0098
OBTAINEDBFR00410
BFR00420
BFR00430
BFROCI440
BFR00450
BFR00460
BFR00470
BFR00480
BFR00490
BFR00500
BFR00510
BFR00520
BFR00530
BFR00540
BFR00550
BFR00560
BFR00570
BFR00580
BFR00590
BFR00600
-------
TAMID - GETTA(ZMID) BFR00610
C BFR00620
C BRUNT-VAISALA FREQUENCY AND FROUDE NUMBER: BFR00630
C BFR00640
IF(DTHETA .LE. 0.00) THEN BFR00650
BULKFR - 999. BFR00660
RETURN BFR00670
ELSE BFR00680
BVF - SQRT(9.8/TAMID * DTHETA) BFR00690
BULKFR » WSAVG/(BVF * HCUTOF) BFR00700
ENDIF BFR00710
RETURN BFR00720
END BFR00730
-------
FUNCTION DELWD( WD1, WD2)
C PURPOSE: THIS FUNCTION COMPUTES THE DIFFERENCE BETWEEN TWO WIND
C DIRECTIONS .
C
C ASSUMPTIONS: THE RETURNED DIFFERENCE BETWEEN THE TWO DIRECTIONS
C BE GREATER THAN 180 DEGREES IN MAGNITUDE.
C
C ARGUMENTS
C PASSED:
C WD1 REAL LOWER WIND DIRECTION
C WD2 REAL UPPER WIND DIRECTION
C RETURNED FUNCTION VALUE:
C DELWD REAL DELWD-WD2-WD1
C
C CALLING ROUTINES:
C SEQMOD WDPRO
C
C INTRINSIC FUNCTIONS:
C ABS
C
C COMMON BLOCKS: NONE
C
C
C DEFINE ARGUMENTS
REAL WD1 , WD2
C
DELWD-WD2-WD1
IF(ABS(DELWD) .GT. 180.0) THEN
IF(DELWD .GT. 0.0) THEN
DELWD-DELWD-3 60.0
ELSE
DELWD-DELWD+360 . 0
ENDIF
ENDIF
C
RETURN
END
DWD00010
DWD00030
DWD00040
DWD00050
CANNOTDWD00060
DWD00070
DWD00080
DWD00090
DWDCI0100
DWD00110
DWD00120
DWD00130
DWD00140
DWD00150
DWD00160
DWD00170
DWD00180
DWD00190
DWD00200
DWD00210
DWD00220
DWD00230
DWD00250
DWD00260
DWD00270
DWD00280
DWD00290
DWD00300
DWD00310
DWD00320
DWD00330
DWDOG340—
DWD00350
DWD00360
DWD00370
DWD00380
DWD00390
10
-------
REAL FUNCTION ERF(X)
C ERROR FUNCTION ROUTINE
C
c USING RATIONAL CHEBYSHEV APPROXIMATIONS, ERF(X) AND ERFC(X) ARE
C COMPUTED TO ABOUT 1 PART IN 10**16. SEE W. J. CODY, MATHEMATICS
C OF COMPUTATION, 23, 107, 631. (JULY 1969).
c COMPUTATIONS ARE DONE IN REAL*8. FOR SINGLE PRECISION CALLS
C THE ACCURACY DROPS VIA TRUNCATION TO ABOUT 1 IN 10**7.
C THE VARIOUS COMPUTATIONAL CUTOFFS ARE IDENTICAL TO IBM'S.
C *** V3.21
C
C ARGUMENTS:
C PASSED:
C RETURNED:
C
C I/O: NONE
C
C CALLING ROUTINES: FLOW LIFTIN LVDF WRAP
C
C EXTERNAL ROUTINES:
C
C ENTRY POINTS: DERF DERFC ERFC
C
C INTRINSIC FUNCTIONS: ABS DABS DEXP
C
C INCLUDE FILES: NONE
C
C COMMON BLOCKS: NONE
C
C
DOUBLE PRECISION XX, DERF, DERFC
DOUBLE PRECISION CERF , CERFC , SQRTPI
DOUBLE PRECISION X1,X2 ,X3 ,X4 ,X5,X6,X7,X8,X10
DOUBLE PRECISION P10, P12 , P14 , P16 , P18 ,Q10 ,Q12 , Q14 ,Q16,Q18
DOUBLE PRECISION P20 , P21, P22 , P23 , P24 , P25 , P26, P27 , P28
DOUBLE PRECISION Q20 ,Q21,Q22 ,Q23 ,Q24 ,Q25 ,Q26 ,Q27 ,Q28
DOUBLE PRECISION P30,P32,P34 ,P36,P38,P3A,Q30,Q32,Q34 ,Q36,Q38 ,Q3A
C
DATA SQRTPI/1.772453850905516DO/
DATA P10/3 . 209377589138469D3/ , P12/3 . 774852376853020D2/ ,
R P14/1.138641541510502D2/,P16/3.161123743870566DO/,
R P18/1.857777061846032D-1/,Q10/2.844236833439171D3/,
R Q12/1.282616526077372D3/,Q14/2.440246379344442D2/,
R Q16/2.360129095234412D1/,Q18/1.0DO/
DATA P20/1. 230339354797997D3/ , P21/2 . 051078377826071D3/ ,
R P22/1.712047612634071D3/,P23/8.819522212417691D2/,
R P24/2 . 986351381974001D2/ , P25/6 . 611919063714163D1/ ,
R P26/8.883149794388376DO/,P27/5.641884969886701D-1/,
R P28/2.153115354744038D-8/,Q20/1.230339354803749D3/,
R Q21/3.439367674143722D3/,Q22/4.362619090143247D3/,
R Q23/3.290799235733460D3/,Q24/1.621389574566690D3/,
R Q25/5.371811018620099D2/,Q26/1.176939508913125D2/,
R Q27/1 . 574492611070983D1/ , Q28/1 . ODO/
DATA P30/6.587491615298378D-4/,P32/1.608378514874228D-2/,
R P34/1.257817261112292D-1/,P36/3.603448999498044D-1/,
R P38/3 . 053266349612323D-1/ , P3A/1. 631538713730210D-2/ ,
R Q30/2.335204976268692D-3/,Q32/6.051834131244132D-2/,
R Q34/5.279051029514284D-1/,Q36/1.872952849923460DO/,
ERF00010
ERF00030
ERF00040
ERF00050
ERF00060
ERF00070
ERF00080
ERF00090
ERF00100
ERF00110
ERF00120
ERF00130
ERF00140
ERF00150
ERF00160
ERF00170
ERF00180
ERF00190
ERF00200
ERF00210
ERF00220
ERF00230
ERF00240
ERF00250
ERF00260
ERF00270
ERF00280
ERF00290
ERF00300
T?O B* f\ f\ 1 1 rt
~CiKr uu j iO
ERF00320
ERF00330
ERF00343-
ERF00350
ERF00360
ERF00370
ERF00380
ERF00390
ERF00400
ERF00410
ERF00420
ERF00430
ERF00440
ERF00450
ERF00460
ERF00470
ERF00480
ERF00490
ERF00500
ERF00510
ERF00520
ERF00530
ERF00540
ERF00550
ERF00560
ERF00570
ERF00580
ERF00590
ERF00600
11
-------
R Q38/2.568520192289822DO/,Q3A/1.0DO/
IENTER-1
CERF=1.0
IF(X.LT.O.O) CERF—1.0
Xl-ABS(X)
IF(X1.GE.3.919206) GO TO 50
GO TO 6
C
ENTRY ERFC(X)
C
IENTER-2
CERFOO. 0
IF(X.LT.O.O) CERF02.0
IF(X.GE.13.306 .OR. X.LE.-3.919206) GO TO 50
Xl-ABS(X)
GO TO 6
C
ENTRY DERF(XX)
C
IENTER»3
CERF-1.0
IF(XX.LT.O.O) CERF—1.0
Xl-DABS(XX)
IF(X1.GE.6.092368) GO TO 50
GO TO 4
C
ENTRY DERFC(XX)
C
IENTER-4
CERFC-0.0
IF(XX.LT.0.0) CERFC-2.0
IF(XX.GE.13.306 .OR. XX.LE.-6.092368) GO TO 50
Xl-DABS(XX)
4 X-XX
6 X2-X1*X1
X4-X2*X2
X6-X4*X2
X8-X4*X4
IF(Xl.LE.O.S) GO TO 10
IF(X1.GE.4.0) GO TO 30
C (20)METHOD 2. FOR X BETWEEN 0.5 AND 4.0
X3-X2*X1
X5-X4*X1
X7-X6*X1
CERFC-DEXP(-X2)*(P20+P21*X1+P22*X2+P23*X3+P24*X4+P25*X5+P26*X6+
X P27*X7+P28*X8)/(Q20+Q21*X1+Q22*X2+Q23 *X3+Q24*X4+Q25*X5+Q26 *X6+
X Q27*X7+Q28*X8)
IF(X.LT.O.O) CERFO2.0-CERFC
CERF-l.O-CERFC
GO TO 50
10 CERF-X1*(P10+P12*X2+P14*X4+P16*X6+P18*X8)/(Q10+Q12*X2+Q14*X4+
X Q16*X6+Q18*X8)
IF(X.LT.O.O) CERF—CERF
CERFC-l.O-CERF
GO TO 50
30 X10-X8*X2
CERFC— (P30+P32/X2+P34/X4+P36/X6+P38/X8+P3A/X10) / (Q30+Q32/X2-1-
X Q34/X4+O.36/X6+Q38/X8+Q3A/X10)/X2+1.0/SQRTPI
CERFOCERFC*DEXP (-X2) /Xl
IF(X.LT.O.O) CERF02.0-CERFC
ERF00610
ERF00620
ERF00630
ERF00640
ERF00650
ERF00660
ERF00670
ERF00680
ERF00690
ERF00700
ERF00710
ERF00720
ERF00730
ERF00740
ERF00750
ERF00760
ERF00770
ERF00780
ERF00790
ERF00800
ERF00810
ERF00820
ERF00830
ERF00840
ERF00850
ERF00860
ERF00870
ERF00880
ERF00890
ERF00900
ERF00910
ERF00920
ERF00930
ERF0094&-
ERF00950
ERF00960
ERF00970
ERF00980
ERF00990
ERF01000
ERF01010
ERF01020
ERF01030
ERF01040
ERF01050
ERF01060
ERF01070
ERF01080
ERF01090
ERF01100
ERF01110
ERF01120
ERF01130
ERF01140
ERF01150
ERF01160
ERF01170
ERF01180
ERF01190
ERF01200
12
-------
CERF-l.O-CERFC ERF01210
50 GO TO (51,52,53,54),IENTER ERF01220
51 ERF-CERF ERF01230
RETURN ERF01240
52 ERFOCERFC ERF01250
RETURN ERF01260
53 DERF-CERF ERF01270
RETURN - ERF01280
54 DERFC=CERFC ERF01290
RETURN ERF01300
END ERF01310
13
-------
SUBROUTINE FLAT ( QS , HEIGHT )
C PURPOSE: PERFORM FLAT TERRAIN CALCULATIONS
C
C ARGUMENTS:
C PASSED:
C QS REAL EMISSION RATE (G/SEC)
C HEIGHT REAL RECEPTOR HEIGHT ABOVE THE SURFACE (M)
C RETURNED: NONE
C
C I/O:
C INPUT: NONE
C OUTPUT: UNIT=IOUT CONCENTRATIONS
C
C CALLING ROUTINES: LIFT SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: COS EXP SIN SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST 10 PARAMS PASL PASVAL VARS
C
C
INCLUDE 'PARAMS.INC1
INCLUDE ' CONST. CMN'
INCLUDE 'IO.CMN'
INCLUDE 'PARAMS. CMN'
INCLUDE 'PASL. CMN'
INCLUDE 'PASVAL. CMN'
INCLUDE 'VARS. CMN'
C
REAL QS
DATA ARGMAX/30./,TENSIX/1000000./
C
C INITIALIZE CONCENTRATION
C-0 . 0
C ORIENT X-AXIS ALONG THE DIRECTION OF THE FLOW
ROTFLO-PIBY2+PHIM
DUMS-SIN (ROTFLO)
DUMC-COS (ROTFLO)
XSPF-XS *DUMC+YS *DUMS
YSPF— XS*DUMS+YS*DUMC
XRPF-XR*DUMC+YR*DUMS
YRPF— XR*DUMS+YR*DUMC
C CALCULATE THE DISTANCE TO THE RECEPTOR
DX-XRPF-XSPF
DY-YRPF-YSPF
C CALCULATE TIME-OF-TRAVEL TO RECEPTOR
TR-DX/UV
ZT-TR+ZTV
YT-TR+YTV
IF(TR .LE. 0.) THEN
IF(ICASE .EQ. 1) WRITE (IOUT, 100) NR
RETURN
ENDIF
C CALCULATE SIGMA-Z EQN. 12
SZ-SIGW*ZT/SQRT( 1.0 + 0.5*ZT/TTLZ)
FLT00010
FLT00030
FLT00040
FLT00050
FLT00060
FLT00070
FLT00080
FLT00090
FLT00100
FLT00110
FLT00120
FLT00130
FLT00140
FLT00150
FLT00160
FLT00170
FLT00180
FLT00190
FLT00200
FLT00210
FLT00220
FLT00230
FLT00240
FLT00260
FLT00270
FLT00280
FLT00290
FLT00300
FLT00310
FLT00320
FLT00330
FLT0034&-
FLT00350
FLT00360
FLT00370
FLT00380
FLT00390
FLT00400
FLT00410
FLT00420
FLT00430
FLT00440
FLT00450
FLT00460
FLT00470
FLT00480
FLT00490
FLT00500
FLT00510
FLT00520
FLT00530
FLT00540
FLT00550
FLT00560
FLT00570
FLT00580
FLT00590
FLT00600
14
-------
S2SQ=SZ*SZ FLT00610
C CALCULATE SIGMA-Y EQN. 19 FLT00620
SY»SIGV*YT/SQRT(1.+.5*YT/TTLY) FLT00630
SYSQ=-SY*SY FLT00640
C COMPUTE THE CONCENTRATION IN MICROGRAMS/M**3 FLT00650
TERMZP =0.0 FLT00660
TERMZM =0.0 FLT00670
DHP=HPL+HELGHT FLT00680
DHM=HPL-HEI-GHT FLT00690
CO«QS*TENSIX FLT00700
ARGY = 0.5*~DY*DY/SYSQ FLT00710
C CONCENTRATION IS ZERO IF HORIZONTAL FACTOR IS ZERO FLT00720
IF(ARGY .LT. ARGMAX) THEN FLT00730
FACY = EXP(-ARGY) FLT0074C
ARGZP =• 0.5*DHP*DHP/SZSQ FLT00750
ARGZM - 0.5*DHM*DHM/SZSQ FLT00760
IF(ARGZP .LT. ARGMAX) TERMZP = EXP(-ARGZP) FLT00770
IF(ARGZM .LT. ARGMAX) TERMZM - EXP(-ARGZM) FLT00780
C=»CO*FACY*(TERMZP+TERMZM)/ (2 .*PI*UV*SY*SZ) FLT00790
ENDIF FLT00800
IF(ICASE .EQ. 1) WRITE(IOUT,101) NR,DX,DY,Z,DHM,SY,SZ,SY,SZ,C FLT00810
100 FORMAT(IX,13,' NO FLAT CALCULATION; REC. UPWIND OF SOURCE1) FLT00820
101 FORMAT(/1X,13,' F ',F8.1,3X,F8.1,2X,F7.1,2X,F7.1,IX,2F6.1,IX, FLT00830
1 2F6.1,1X,1PE10.4) FLT00840
RETURN FLT00850
END FLT00860
15
-------
SUBROUTINE FLOW ( X , Y , Z , ETA , DEL , THI , TLI , TU )
C DESCRIPTION :
C COMPUTES THE PERTURBATION WINDS UP,VP,WP AT (X,Y,Z) AND
C COMPUTES THE VERTICAL AND LATERAL DEFLECTIONS (ETA, DEL) OF THE
C STREAMLINE THAT PASSES THROUGH THE POINT (X,Y,Z) ABOVE THE
C SURFACE OF A ROTATED GAUSSIAN HILL.
C *** THIS CODE HOW COMPUTES IDYY, AND IXXDYY TO COMPUTE T-FACTORS.
C TLI - 1.0 - D(DEL)/DY - 1.0 + (IDYY + BVUI2*IXXDYY)
C THI - 1.0 - D(ETA)/DZ - 1.0 + IDZZ
C
C *** THIS STRATIFIED FLOW CALCULATION ACCOUNTS FOR ARBITRARY
C STRATIFICATION, N/U, (INCLUDING NEUTRAL) IN THE NEAR FIELD
C OF THE HILL (I.E. X < LX, Y < LY, 2 « LX OR LY ) .
C *** LINEAR WIND SHEAR CORRECTIONS ARE ADDED IN SUCH THAT NEUTRAL
C DEFLECTIONS ARE CORRECT TO LOWEST ORDER IN THE SHEAR GRADIENT.
C *** U"/U - 0 IS ASSUMED BUT N/U IS COMPUTED FROM FR ABOVE HC.
C
C ARGUMENTS:
C PASSED
C X REAL X COORDINATE (POSITIVE DOWNWIND OF HILL CENTER)
C Y REAL Y COORDINATE (POSITIVE LEFT OF HILL CENTER)
C Z REAL Z COORDINATE (POSITIVE ABOVE HILL SURFACE)
C RETURNED
C ETA REAL VERTICAL DEFL. OF STREAMLINE PASSING (X,Y,Z)
C DEL REAL LATERAL DEFLECTION OF STREAMLINE PASSING (X,Y,Z)
C TLI REAL 1.0/(TL FACTOR) AT (X,Y,Z)
C THI REAL 1.0/(TH FACTOR) AT (X,Y,Z)
C TU REAL TU FACTOR AT (X,Y,Z)
C
C CALLING ROUTINES: LIFT PATH
C
C EXTERNAL ROUTINES: HILHGT
C
C INTRINSIC FUNCTIONS:
C
C INCLUDE FILES:
C
FLW00010
-FLW00020
FLW00030
FLW00040
FLW00050
FLW00060
FLW00070
FLW00080
FLW00090
FLW00100
FLW00110
FLW00120
FLWCI0130
FLW00140
FLW00150
FLW00160
FLW00170
FLW00180
FLW00190
FLW00200
FLW00210
FLW00220
FLW00230
FLW00240
FLW00250
FLW00260
FLW00270
FLW00280
FLW00290
FLW00300
FLW00310
FLW00320
FLW00330
FLW00340-
FLW00350
FLW00360
FLW00370
FLW00380
C COMMON BLOCKS: FLW00390
C FLW00410
INCLUDE 'PARAMS.INC1
INCLUDE 'P ARAMS. CMN'
INCLUDE 'CONST. CMN1
INCLUDE 'PASL.CMN'
INCLUDE 'VARS.CMN'
C
REALM LXI , LYI , LXI2 , LYI2 , LYI3 , LZ , L2I , LN, LNI
REAL*4 I,IDY,IDZ,IDX,IDXX,IDXY,IDXZ
REAL*4 IX, IXDY, IXX, IXXDY, IDYY, IDZZ , IXXDYY, ID3Y, IXXD3Y
DATA ZERO/0 . O/ , ONE/1 . O/ , TWO/2 . O/ , THREE/3 . O/ , FOUR/4 . O/
DATA HALF/0.5/, BON/1. 25/,RNLZ/0. 69315/
DATA WTB/1.25/
C
C *** HOST OF THIS CODE COMPUTES I AND ITS INTEGRALS AND DERIVATIVES.
C THE NOTATION IS SEEN IN THE EXAMPLE IXDY, WHICH IS I INTEGRATED
C ONCE IN X (FROM -INFINITY TO X) AND DIFFERENTIATED IN Y.
C
PII - ONE / PI
RTPII - ONE / SQRPI
FLW00420
FLW00430
FLW00440
FLW00450
FLW00460
FLW00470
FLW00480
FLW00490
FLW00500
FLW00510
FLW00520
FLW00530
FLW00540
FLW00550
FLW00560
FLW00570
FLW00580
FLW00590
FLW00600
16
-------
c ***
c
c ***
c
c
c
c
c ***
c
c
c
c
c ***
c ***
c
c
c ***
COMPUTE NEEDED LENGTH SCALE FACTORS.
LXI - ONE / LX
LXI2 - LXI * LXI
LYI - ONE / LY
LYI2 - LYI * LYI
LYI3 - LYI2 * LYI
LZI - SQRT(HALF * (LXI2 + LYI2) ) / RNLZ
LZ - ONE /- LZI
LN - HALF * SQRPI * LZ
LNI - ONE / LN
XDLX - X * LXI
YDLY - Y * LYI
YDLY2 - YDLY * YDLY
COMPUTE THE MODIFIED COORDINATES XM,YM AND THEIR
DIMENSIONLESS FORMS XMDLX,YMDLY.
XM - X + GAM*LX*LX*Y
YM - Y + GAM*LY*LY*X
XMDLX - XM * LXI
XMDLX2 - XMDLX * XMDLX
YMDLY - YM * LYI
YMDLY2 - YMDLY * YMDLY
GAMLX - GAM * LX
GAMLX2 - GAMLX * GAMLX
GAMP - ONE - GAMLX2*LY*LY
GAMP2 - GAMP * GAMP
HHXY - HH * HILHGT(X,Y) BUT COMPUTE IN CODE BELOW.
ARG - XDLX*XDLX + YDLY*YDLY + 2.0*GAM*X*Y
IF(ARG .GT. 30.) ARG - 30.
EXPARG - EXP(-ARG)
HHXY - HH * EXPARG
OBTAIN CORRECT WIND SPEED, U, USING SPEED
U • SPEED(HHXY+Z)
UI - ONE / U
COMPUTE THE SHEAR FACTORS THAT ARE NEEDED.
UO - AMIN1(SPEED(HHXY),U)
SHRF - SQRT(UO*UI)
SHRFDZ - -HALF * ALP * UI
SHRC-HALF*ALF/UO
COMPUTE THE ADDITIONAL Z SUPRESSION FACTOR FROM NEUTRAL FLOW
ZFACI - ONE / (ONE + LNI * Z)
ZFACDZ - -TWO * LNI * ZFACI
COMBINE WITH SHEAR FACTOR TO GIVE TOTAL Z ADJUSTMENT FACTOR.
TZFAC - SHRF * ZFACI * ZFACI
TZFDZ - SHRFDZ + ZFACDZ
TZFDZZ - TZFDZ*TZFDZ - SHRFDZ*ALF*UI - ZFACDZ*LNI*ZFACI
COMPUTE THE HILL ASYMMETRY FACTOR HASYM.
HASYM - SQRT(1.0+LX*LX*LYI2)
IF(HASYM .GT. SQR2) HASYM - SQR2
COMPUTE CORRECTED STRATIFICATION, S.
BVUI - ONE/(FR*HH)
IF(FR .GT. 50.) BVUI-0.
BVUI2 - BVUI * BVUI
EQN. A-19B
FLW00610
FLW00620
FLW00630
FLW00640
FLW00650
FLW00660
FLW00670
FLW00680
FLW00690
FLW00700
FLW00710
FLW00720
FLW00730
FLW00740
FLW00750
FLW00760
FLW00770
FLW00780
FLW00790
FLW00800
FLW00810
FLW00820
FLW00830
FLW00840
FLW00850
FLW00860
FLW00870
FLW00880
FLW00890
FLW00900
FLW00910
FLW00920
FLW00930
FLW0094S-
FLW00950
FLW00960
FLW00970
FLW00980
FLW00990
FLW01000
FLW01010
FLW01020
FLW01030
FLW01040
FLW01050
MATCHFLW01060
FLW01070
FLW01080
FLW01090
FLW01100
FLW01110
FLW01120
FLW01130
FLW01140
FLW01150
FLW01160
FLW01170
FLW01180
FLW01190
FLW01200
17
-------
S - BVUI * HASYM
S2 - S*S
BON2 - BON * BON
BO » S * LZ- * RTPII
B02 - BO * BO
* BON
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
AST - TWO * RTPII * S2 * LZ * PII * BON2 - SHRC
ASTDS2 IS ACTUALLY AST/(S*BVUI)
ASTDS2 - TWO * RTPII * LZ * PII * HASYM
HHM IS THE COEFFICIENT OF I AT X-Y-0
HHM - HH * LN / (ONE + B02)
HHXYM IS THE COEFFICIENT OF I AWAY FROM HILL CREST
HHXYM - HHM * EXPARG
*** COMPUTE THE STRATIFICATION HEIGHT, SZ.
SZ - S * Z
*** COMPUTE THE VARIOUS 'ANGULAR FACTORS', AFN, AND THEIR
ADN, CONDITIONED ON THE VALUE OF SZ.
IF(SZ .LE. 0.005) THEN
CSZ - ONE
SSZ - SZ
AF1 - Z
ADI - ONE
ADD1 - S * SZ
ELSE
SI - ONE / S
CSZ - COS(SZ)
SSZ - SIN(SZ)
AF1 - SSZ * SI
ADI - CSZ
ADD1 - -S * SSZ
ENDIF
AFO - CSZ / ZFACI
ADO - LNI * CSZ - S * SSZ / ZFACI
*** OVERRIDE AFO-CSZ WITH AFO-ONE. 10/8/86
AFO - ONE / ZFACI
ADO - LNI
ADDO - -S2 / ZFACI
AF2SHR - TWO * LNI + SHRC
AF2 - S * CSZ + AF2SHR * SSZ
AD2 * -S2 * SSZ + AF2SHR * S * CSZ
ADD2 - -S2 * (S * CSZ + AF2SHR * SSZ)
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR I.
TO - ONE
Tl - -AST
??? T2 - -ASTDS2*XMDLX
TRY SETTING T2-0. FOR XM LESS THAN ZERO
T2 - 0.
IF(XM .GE. 0.) T2 - -ASTDS2*XMDLX
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
*** COMPUTE THE BASIC QUANTITY I EQN. A-27
I - TZPAC * HHXYM * SUM
FLW01210
FLW01220
FLW01230
FLW01240
FLW01250
FLW01260
FLWO1270
FLW01280
FLW01290
FLW01300
FLW01310
FLW01320
FLW01330
FLW01340
FLW01350
FLW01360
DERIVATIVES,FLWO13 7 0
FLWCI1380
FLWCI1390
FLWO1400
FLW01410
FLWO1420
FLWO1430
FLWO1440
FLW01450
FLWO1460
FLW01470
FLWO1480
FLWO1490
FLWO1500
FLWO1510
FLWO1520
FLW01530
FLWO1540-
FLWO1550
FLW01560
FLWO1570
FLW01580
FLWO1590
FLW01600
FLW01610
FLW01620
FLW01630
FLW01640
FLW01650
FLW01660
FLWO1670
FLWO1680
FLW01690
FLWO1700
FLWO1710
FLWO1720
FLW01730
FLW01740
FLW01750
FLWO1760
FLW01770
FLW01780
FLWO1790
FLW01800
18
-------
c ***
c
c ***
COMPUTE THE VARIOUS INTEGRAL TERMS FOR IDZ.
TIO - TO * ADO
Til - Tl * ADI
TI2 - T2 * AD2
SUM - TIO + Til + TI2
COMPUTE THE DERIVATIVE OF I WITH RESPECT TO Z.
TERM1 - TZFAC * HHXYM * SUM
IDZ - TERM1 -I- TZFDZ * I
...EQN. A-28
C
C ***
c
c ***
c
c
c ***
c
c
c
c
c
c
c
COMPUTE THE SECOND DERIVATIVE OF I WITH RESPECT TO Z.
TIO - TO * ADDO
Til - Tl * ADD1
TI2 - T2 * ADD2
SUM - TIO + Til + TI2
COMPUTE THE SECOND DERIVATIVE OF I WITH RESPECT TO Z EQN.A'
IDZZ - TZFAC * HHXYM * SUM + TWO * TZFDZ * TERM1 + TZFDZZ *
COMPUTE THE VARIOUS INTEGRAL TERMS FOR IDX AND IDXZ.
TO - ZERO
Tl - ZERO
T2 - -ASTDS2 * LXI
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
SUM - TI2
C
c
c
c
COMPUTE THE QUANTITY IDX.
TERM2 - TZFAC * HHXYM * SUM
IDX - -TWO * XMDLX * LXI * I
NOW COMPUTE THE D/DZ TERMS.
TIO - TO * ADO
Til - Tl * ADI
TI2 - T2 * AD2
SUM - TIO + Til + TI2
SUM - TI2
EQN. A-30
+ TERM2
C
c ***
c
c
c ***
c
c
c
c
c
c
c
c
c
c ***
COMPUTE THE DERIVATIVE OF IDX WITH RESPECT TO Z.
TERM3 - TZFAC*HHXYM*SUM
IDXZ - -TWO*XMDLX*LXI*IDZ + TZFDZ*TERM2 + TERM3
COMPUTE THE QUANTITIES NEEDED FOR IDXX.
TO - ZERO
Tl - ZERO
T2 - ZERO
TIO - TO * AFO
Til - Tl * ATI
TI2 - T2 * AF2
SUM - TIO + Til + TI2
SUM - ZERO
COMPUTE THE QUANTITY IDXX EQN. A-31
IDXX - -TWO * LXI2 * (ONE + TWO * XMDLX2) * I
.EQN. A-32
FLW01810
FLW01820
FLW01830
FLW01840
FLW01850
FLW01860
FLW01870
FLW01880
FLW01890
FLW01900
FLW01910
FLW01920
FLW01930
FLW01940
FLW01950
FLW01960
•29FLW01970
I FLW01980
FLW01990
FLW02000
FLW02010
FLW02020
FLW02030
FLW02040
FLW02050
FLW02060
FLW02070
FLW02080
FLW02090
FLW02100
FLW02110
FLW02120
FLW02130
FLW0214&-
FLW02150
FLW02160
FLW02170
FLW02180
FLW02190
FLW02200
FLW02210
FLW02220
FLW02230
FLW02240
FLW02250
FLW02260
FLW02270
FLW02280
FLW02290
FLW02300
FLW02310
FLW02320
FLW02330
FLW02340
FLW02350
FLW02360
FLW02370
FLW02380
FLW02390
FLW02400
19
-------
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
FOUR * XMDLX * LXI * IDX + TZFAC * HHXYM * SUM
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IDY.
TO » ZERO
Tl = ZERO
T2 = -ASTDS2 * GAMLX
TIO - TO * .AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
SUh = TI2
*** COMPUTE THE QUANTITY IDY ..... EQN. A-33
IDY - -TWO * LYI * YMDLY * I + TZFAC * HHXYM * SUM
*** COMPUTE THE QUANTITY IDYY ..... EQN. A-34
IDYY - -TWO * LYI2 * (ONE + TWO * YMDLY2) *
X FOUR * YMDLY * LYI * IDY
I -
*** COMPUTE THE QUANTITY ID3Y
ID3Y - -8.0 * LYI3 * YMDLY *
X TWO * LYI2 * (THREE +
EQN. A-35
I - FOUR * LYI * YMDLY-*
TWO * YMDLY2) * IDY
IDYY -
c
c
*** COMPUTE THE QUANTITIES NEEDED FOR IDXY.
TO - ZERO
Tl - ZERO
T2 - ZERO
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
SUM - ZERO
*** COMPUTE THE QUANTITY IDXY. ....EQN. A-36
IDXY - -TWO * (GAM + TWO * XM * YM * LXI2 * LYI2) * I -
X TWO * XMDLX * LXI * IDY -
X TWO * YMDLY * LYI * IDX + TZFAC * HHXYM * SUM
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IXXDY.
NOTE THAT IXX IS ALSO NEEDED FOR THIS.
COMPUTE THE GNX AND GNXX FACTORS.
$$S GOX - HALF * SQRPI * ( ONE + ERF(XMDLX) )
INSERT THE FOLLOWING FIX TO KILL LAT. DEFL. GROWTH. 10/1/86
GOX - HALF * SQRPI * ( ONE - ERF( ABS(XKDLX) ) )
IF(XMDLX2 .GT.30.) XMDLX2 - 30.
G1X - -HALF * EXP(-XMDLX2)
GOXX - XMDLX * GOX - G1X
G1XX - -HALF * GOX
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IXX.
TO - GOXX
FLW02410
FLW02420
FLW02430
FLW02440
FLW02450
FLW02460
FLW02470
FLW02480
FLW02490
FLW02500
FLW02510
FLW02520
FLW02530
FLW02540
FLW02550
FLW02560
FLW02570
FLW02530
FLW02590
FLW02600
FLW02610
FLW02620
FLW02630
FLW02640
FLW02650
FLW02660
FLW02670
FLW02680
FLW02690
FLW02700
FLW02710
FLW02720
FLW02730
FLW0274CT
FLW02750
FLW02760
FLW02770
FLW02780
FLW02790
FLW02800
FLW02810
FLW02820
FLW02830
FLW02840
FLW02850
FLW02860
FLW02870
FLW02880
FLW02890
FLW02900
FLW02910
FLW02920
FLW02930
FLW02940
FLW02950
FLW02960
FLW02970
FLW02980
FLW02990
FLW03000
20
-------
c
c
c
...EQN. A-42
C
C
Tl - -GOXX
Tl - AST * Tl
T2 - -ASTDS2*G1XX
TIO » TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO * Til + TI2
*** COMPUTE THE QUANTITY IXX.
QX - YDLY2 - GAMLX2 * Y * Y
QX - YDLY2 * GAMP
IF(QX .GT.30.) QX - 30.
EFAC - EXP(-QX)
HHLX2E - HHM * LX * LX * EFAC
IXX - TZFAC * HHLX2E * SUM
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IXXDY.
TO - GAMLX*GOX
Tl - -GAMLX*GOX
Tl - AST * Tl
T2 - -ASTDS2*GAMLX*G1X
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
C
C
C
C
*** COMPUTE THE QUANTITY IXXDY. EQN.
IXXOY - -TWO * LYI2 * Y * GAMP * IXX +
A-44
TZFAC * HHLX2E * SUM
C
C
c
c
c
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IX.
TO - +GOX
Tl - -GOX
Tl - AST * Tl
T2 - -ASTDS2*G1X
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
*** COMPUTE THE QUANTITY IX. ....EQN. A-41
IX - TZFAC * HHLX2E * LXI * SUM
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IXDY.
HHJ - GAMLX * EXP(-XMDLX2) * XMDLX**J BUT SEE G1X
HHO - -TWO * G1X * GAMLX
HH1 - HHO * XMDLX
HH2 - HH1 * XMDLX
TO <- HHO
Tl - -HHO
Tl - AST * Tl
T2 - -ASTDS2*HH1
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
FLW03010
FLW03020
FLW03030
FLW03040
FLW03050
FLW03060
FLW03070
FLW03080
FLW03090
FLW03100
FLW03110
FLW03120
FLW03130
FLW03140
FLW03150
FLW03160
FLW03170
FLH03180
FLW03190
FLW03200
FLW03210
FLW03220
FLW03230
FLW03240
FLW03250
FLW03260
FLW03270
FLW03280
FLW03290
FLW03300
FLW03310
FLW03320
FLW03330
FLW0334O-
FLW03350
FLW03360
FLW03370
FLW03380
FLW03390
FLW03400
FLW03410
FLW03420
FLW03430
FLW03440
FLW03450
FLW03460
FLH03470
FLW03480
FLW03490
FLW03500
FLW03510
FLW03520
FLW03530
FLW03540
FLW03550
FLW03560
FLW03570
FLW03580
FLW03590
FLW03600
21
-------
*** COMPUTE THE QUANTITY IXDY.
IXDY - -TWO * LYI2 * Y * GAMP
.EQN. A-45
IX + TZFAC * HHLX2E
* LXI * SUM
C
c
C
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
*** COMPUTE THE QUANTITY IXXDYY EQN. A-46
(NOTE THAT IXXDYY USES THE SAME SUM AS IXDY)
IXXDYY - -TWO * LYI2 * GAMP * IXX * (ONE + TWO*GAMP*YDLY2) -
X EOUR * LYI2 * Y * GAMP * IXXDY +
X TZFAC * HHLX2E * GAMLX * SUM
*** COMPUTE THE VARIOUS INTEGRAL TERMS FOR IXXD3Y.
TO - -TWO * HH1
Tl - +TWO * HH1 s
Tl - AST * Tl v
T2 - -ASTDS2 * (HHO - TWO*HH2)
TIO - TO * AFO
Til - Tl * AF1
TI2 - T2 * AF2
SUM - TIO + Til + TI2
*** COMPUTE THE QUANTITY IXXD3Y. EQN. A-47
IXXD3Y - -FOUR*LYI3*GAMP2*IXX*YDLY*(THREE+TWO*GAMP*YDLY2) •
X 6.0 * LYI2 * GAMP * IXXDY * (ONE+TWO*GAMP*YDLY2)
X 6.0 * LYI * GAMP * YDLY * IXXDYY +
X TZFAC * HHLX2E * GAMLX2 * SUM
*** COMPUTE THE STREAMLINE DEFLECTIONS.
*** COMPUTE THE VERTICAL DEFLECTION AS -(D/DZ) I. ....EQN. A-22A
ETA - -IDZ
*** NOW COMPUTE THE LATERAL DEFLECTION AS EQN. A-22E
DEL - -(D/DY)(IDY+BVUI2*IXX) - -(IDY + BVUI2*IXXDY)
*** AND COMPUTE ITS FIRST AND SECOND DERIVATIVES
TERM3 - BVUI2 * IXXDY
DEL - -(IDY + TERM3)
DELDY - -IDYY - BVUI2*IXXDYY
DELDYY - -ID3Y - BVUI2*IXXD3Y
*** COMPUTE CORRECTION FACTOR FOR LATERAL DEFLECTIONS
DELC - ONE + ABS(DELDY)
DELCOR - DELC
IF(ABS(DEL).LT.0.001*LY) THEN
DELCOR - ONE
ELSEIF(ABS(DELDYY*LY) .GT. 0.001) THEN
EPS - WTB*DBLDYY*DEL
ARGRT - DELC*DELC-TWO*EPS
RTDELC - 0.
IF(ARGRT .GE. 0.) RTDELC - SQRT(ARGRT)
IF(RTDELC .NE. DELC) DELCOR - EPS/(DELC-RTDELC)
ENDIF
*** APPLY CORRECTION FACTOR
DEL - DEL / DELCOR
*** COMPUTE THE RECIPROCAL OF THE T FACTORS
*** NOTE THAT THE T FACTORS COULD GO TO INFINITY.
TLI - ONE - DELDY/DELCOR
THI - ONE + ID2Z
..EQNS. A-22F,G
FLW03610
FLW03620
FLW03630
FLW03640
FLW03650
FLW03660
FLW03670
FLW03680
FLW03690
FLW03700
FLW03710
FLW03720
FLW03730
FLW03740
FLW03750
FLW03760
FLW03770
FLW03780
FLW03790
FLW03800
FLW03810
FLW03820
FLW03830
FLW03840
FLW03850
FLW03860
FLW03870
FLW03880
FLW03890
FLW03900
FLW03910
FLW03920
FLW03930
FLW03948-
FLW03950
FLW03960
FLW03970
FLW03980
FLW03990
FLW04000
FLW04010
FLW04020
FLW04030
FLW04040
FLW04050
FLW04060
FLW04070
FLW04080
FLW04090
FLW04100
FLW04110
FLW04120
FLW04130
FLW04140
FLW04150
FLW04160
FLW04170
FLW04180
FLW04190
FLW04200
22
-------
c
c
c
c
c
c
c
c
C!
C
c
c
c
c
c
c
c
c
c
c
c
*** COMPUTE THE PERTURBATION VELOCITIES. ...EQNS. A-22B,C,D
*** MOW COMPUTE THE ALONG-WIND VELOCITY PERTURBATION AS
UP/U - -(IDXX + (BV*UI)**2 * I )
NOTE THAT THIS IS JUST THE NEGATIVE OF THE PERTURBATION
PRESSURE DIVIDED BY RHO(0)*U**2.
TERM3 - BVUI2 * I
UP - -(IDXX + TERM3)
*** COMPUTE THE NON-LINEAR PERTURBATION ALA HUNT ET AL.
!!!JUPNL - ( -ONE + SQRT( ABS(ONE + TWO*UP) ) ) * U
UP - UP * U
*** NOW COMPUTE THE LATERAL VELOCITY PERTURBATION AS
VP/U - -(IDXY + (BV*UI)**2 * IXDY)
TERM3 - BVUI2 * IXDY
VP - -(IDXY + TERM3) * U
*** NOW COMPUTE THE VERTICAL VELOCITY PERTURBATION AS -(D/DZ) IDX.
WP - -IDXZ * U
*** COMPUTE THE "SPEED-UP" FACTOR TU
UTOT-SQRT( (U+UP)*(U+UP) + VP*VP + WP*WP )
TU - UTOT*UI
RETURN
END
FLW04210
FLW04220
FLW04230
FLW04240
FLW04250
FLW04260
FLW04270
FLW04280
FLW04290
FLW04300
FLW04310
FLW04320
FLW04330
FLW04340
FLW04350
FLW04360
FLW04370
FLW04380
FLW04390
FLW04400
FLW04410
FLW04420
FLW04430
FLW04440
FLW04450
FLW04460
FLW04470
FLW04480
FLW04490
FLW04500
FLW04510
23
-------
REAL FUNCTION GETDTH(Z2)
C PURPOSE: THIS ROUTINE COMPUTES THE VERTICAL POTENTIAL TEMPERATURE
C GRADIENT AT HEIGHT Z2
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT (M)
C RETURNED FUNCTION VALUE:
C GETDTH REAL VPTG (DEG/M)
C
C I/O: NONE
C
C CALLING ROUTINES: GETTA HCRIT, PLAVG SEQMOD SRISE
C
C EXTERNAL FUNCTIONS: KLOSE
C
C INTRINSIC FUNCTIONS: AMAX1
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL PARAMS VARS
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' SFCMET. CMN1
INCLUDE ' PROFIL . CMN •
INCLUDE ' PARAMS . CMN '
INCLUDE 'VARS. CMN1
C
C DEFINE ARGUMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
REAL DTH1, Zl, TANEW (MAXLEV) , HTTA(MAXLEV) , DTHNEW ( MAXLEV ),
1 HTNEW (MAXLEV)
REAL DEFAUL(2)
INTEGER LEV, N, NNEW, NO
DATA NO/ O/
DATA DEFAUL/0.02, 0.035/
C
C
C CHECK IVPTG SWITCH: - 0 IF ONSITE VPTG DATA IS IGNORED
C - 1 IF ONSITE VPTG DATA IS USED (SCALED)
C
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
IF(KST .LT. 5) THEN
DTHDEF - 0.0
ELSE
DTHDEF - DEFAUL(KST-4)
ENDIF
C-*- IF (IVPTG .EQ. NO) GO TO 200
NNEW - 0
C
C IF ONLY ONE MEASUREMENT LEVEL EXISTS, CANNOT COMPUTE DTHDZ
C FROM OBSERVATIONS
C
GDT00010
GDT00030
GDTCI0040
GDTCI0050
GDT00060
GDT00070
GDT00080
GDT00090
GDT00100
GDT00110
GDT00120
GDT00130
GDT00140
GDT00150
GDT00160
GDT00170
GDT00180
GDT00190
GDT00200
GDT00210
GDT00220
GDT00230
GDT002SO
GDT00260
GDT00270
GDT002SO
GDT00290
GDT00300
GDT00310
GDT00320
GDT00330
GDT00340-
GDT00350
GDT00360
GDT00370
GDT00380
GDT00390
GDT00400
GDT00410
GDT00420
GDT00430
GDT00440
GDT00450
GDTOCI460
GDTOCI470
GDTOCI480
GDT00490
GDT00500
GDT00510
GDT00520
GDT00530
GDT00540
GDTOC550
GDT00560
GDT00570
GDT00580
GDT00590
GDT00600
-------
100
150
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
IF(NHT.EQ.l) GO TO 200
DO 100 N - 1,NHT
IF(TAHR(N).LT.0.0) GO TO 100
NNEW - NNEW + 1
TANEW(NNEW) - TAHR(N)
HTTA(NNEW) - HT(N)
CONTINUE
NNEW - NNEW - 1
IF(NNEW.GE.l) THEN
DO 150 N - 1,NNEW
DELTA - TANEW(N+1) - TANEW(N)
DELZ - HTTA(N+1) - HTTA(N)
DTHNEW(N) - 0.0098 + DELTA/DELZ
HTNEW(N) - HTTA(N) + 0.5*DELZ
CONTINUE
ENDIF
END OF DATA REDUCTION
CHOOSE INTERPOLATION OR ASSIGNMENT OF DTHDZ
IF( NNEW .EQ. 0 ) GO TO 200
LEV IS INDEX OF HT LEVEL CLOSEST TO (BUT LESS THAN) Z2
LEV - KLOSE(HTNEW,NNEW,Z2)
INTERPOLATION SECTION
LEV .LT. NNEW ) THEN
IF( LEV .GE. 1 .AND.
Zl - HTNEW(LEV)
DTH1 - DTHNEW(LEV)
Z3 - HTNEW(LEV-l-l)
DTH3 - DTHNEW(LEV+1)
DX - DTH3 - DTH1
DZ - 23 - Zl
GETDTH - DTH1 + (Z2-Z1)*(DX/DZ)
IF(GETDTH .LT. 0.0) GETDTH - 0.0
RETURN
ELSE IF(LEV.EQ.NNEW) THEN
DTH1 • DTHNEW(NNEW)
Zl - HTNEW(NNEW)
ELSE
DTH1 - DTHNEW(l)
Zl - HTNEW(l)
ENDIF GDT01070
GDT01080
IF HAVE ONLY 1 OBS (OR CANNOT INTERPOLATE), PERSIST THE SINGLE GDT01090
OBSERVATION TO THE DESIRED HEIGHT IF POSITIVE. IF NEGATIVE, USEGDT01100
ZERO IF BELOW XMH, AND USE STABLE DEFAULT IF DESIRED HEIGHT IS GOTO1110
ABOVE XMH AND MEASUREMENT IS BELOW XMH. GDT01120
GDT01130
IF(DTHl.LE.O.O) THEN GOTO1140
IF(Z2 .LT. XMH .OR. (Zl.GT.XMH .AND. Z2.GT.XMH)) THEN GDT01150
GETDTH - 0.0 GDT01160
ELSE GDT01170
GETDTH - AMAX1(DEFAUL(1),DTHDEF) GDT01180
ENDIF GDT01190
ELSE GDT01200
GDT00610
GDT00620
GDT00630
GDT00640
GDT00650
GDT00660
GDT00670
GDT00680
GDT00690
GDT00700
GDT00710
GDT00720
GDT00730
GDT00740
GDT00750
GDT00760
GDT00770
GDT00780
GDT00790
GDT00800
FROM STABILITY CLASSGDT00810
GDT00820
GDT00830
GDT00840
GDT00850
GDT00860
GDT00870
GDT00880
GDT00890
GDT00900
GDT00910
GDT00920
GDT00930
GDT00940-
GDT00950
GDT00960
GDT00970
GDT00980
GDT00990
GDT01000
GDT01010
GDT01020
GDT01030
GDT01040
GDT01050
GDT01060
25
-------
GETDTH = DTH1 GOTO1210
ENDIF GOTO1220
RETURN GDT01230
C GDT01240
C IN THIS SECTION, COMPUTE VPTG FOR THE CASE OF NO OBSERVATIONS. GDT01250
C USE DEFAULT VALUES BASED UPON STABILITY CLASS: GOTO 1260
C 0.02 DEG/M FOR STABILITY CLASS 5; 0.035 DEG/M FOR CLASS 6 GDT01270
C - GDT01280
200 IF(Z2 .LE. XMH) THEN GDT01290
GETDTH - DTHDEF GDT01300
ELSE GDT01310
GETDTH - AMAX1(DEFAUL(1),DTHDEF) GDT01320
ENDIF GDT01330
RETURN GDT01340
END GOTO1350
26
-------
REAL FUNCTION GETSV(Z2)
C PURPOSE: THIS ROUTINE RETURNS A VALUE OF SIGMA-V AT THE DESIRED
C HEIGHT BY SCALING AN EXISTING OBSERVATION OR COMPUTING
C SIGMA-V FROM SURFACE VARIABLES.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT ABOVE GROUND AT WHICH SIGMA-V IS TO
C - BE COMPUTED (M)
C
C RETURNED:
C GETSV REAL THE RETURNED VALUE OF SIGMA-V
C
C I/O: NONE
C
C CALLING ROUTINES: GETUV SEQMOD
C
C EXTERNAL ROUTINES: KLOSE
C
C INTRINSIC FUNCTIONS: NONE
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' SFCMET. CMN1
INCLUDE 'PROFIL. CMN'
C
C DEFINE ARGUMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
INTEGER LEV, N, NNEW
REAL SVNEW(MAXLEV) , HTNEW (MAXLEV) , SVMISS
DATA SVMISS/ O.O/
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEW - 0
DO 100 N - 1,NHT
IF(SVHR(N) .LT. SVMISS ) GO TO 100
NNEW - NNEW + 1
SVNEW(NNEW) - SVHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
C
IF (NNEW .GE. 1) THEN
LEV - KLOSE (HTNEW, NNEW, Z2)
IF(LEV.EQ.O) THEN
Zl * HTNEW(l)
SV1 - SVNEW(l)
ELSE
Zl - HTNEW(LEV)
SV1 - SVNEW(LEV)
ENDIF
ENDIF
GSV00010
GSV00030
GSV00040
GSV00050
GSV00060
GSV00070
GSV00080
GSV00090
GSV00100
GSV00110
GSV00120
GSV00130
G3V00140
GSV00150
GSV00160
GSV00170
GSV00180
GSV00190
GSV00200
GSV00210
GSV00220
GSV00230
GSV00240
GSV00250
GSV00260
GSV00280
GSV00290
GSV00300
GSV00310
GSV00320
GSV00330
GSV0034«-
GSV00350
GSV00360
GSV00370
GSV00380
GSV00390
GSV00400
GSV00410
GSV00420
GSV00430
GSV00440
GSV00450
GSV00460
GSV00470
GSV00480
GSV00490
GSV00500
GSV00510
GSV00520
GSV00530
GSVOOS40
GSV00550
GSVOOS60
GSV00570
GSV00580
GSV00590
GSV00600
27
-------
c
c
c
c
c
c
c
c
IF NO OBSERVATIONS, RETURN MISSING VALUE OF SIGMA-V
IF(NNEW .EQ. 0) THEN
GETSV =- -9.99
RETURN
ENDIF
IN THIS S'ECTION, THERE IS AT LEAST ONE GOOD OBSERVATION
USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE CLOSEST OBS.
IFfLEV.GE.l .AND. LEV.LT.NNEW) THEN
SV3 - SVNEW(LEV+1)
Z3 - HTNEW(LEV+1)
DX - SV3 - SV1
DZ - Z3 - Zl
GETSV - SV1 + (Z2-Z1)*(DX/DZ)
ELSE
GETSV - SV1
ENDIF
RETURN
END
GSVQ0610
GSV00620
GSV00630
GSV00640
GSV00650
GSV00660
GSV00670
GSV00680
GSV00690
GSV00700
GSV00710
GSV00720
GSV00730
GSV00740
GSV00750
GSV00760
GSV00770
GSV00780
GSV00790
GSV00800
GSV00810
GSV00820
GSV00830
28
-------
REAL FUNCTION GETSW(Z2)
C PURPOSE: THIS ROUTINE RETURNS A VALUE OF SIGMA-W AT THE DESIRED
C HEIGHT BY SCALING AN EXISTING OBSERVATION OR COMPUTING
C SIGMA-W FROM SURFACE VARIABLES.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT ABOVE GROUND AT WHICH SIGMA-W IS TO
C BE COMPUTED (M)
C
C RETURNED:
C GETSW REAL THE RETURNED VALUE OF SIGMA-W
C
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: KLOSE
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL PARAMS
C
C
INCLUDE 'PARAMS.INC1
INCLUDE ' S FCMET . CMN '
INCLUDE 'PROFIL. CMN1
C
C DEFINE ARGUMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
INTEGER LEV, N, NNEW
REAL SWNEW(MAXLEV) , HTNEW (MAXLEV) , SWMISS
DATA SWMISS/ O.O/
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEW - 0
DO 100 N - 1,NHT
IF(SWHR(N) .LT. SWMISS ) GO TO 100
NNEW - NNEW + 1
SWNEW(NNEH) - SWHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
C
IF (NNEW .GE. 1) THEN
LEV - KLOSE (HTNEW, NNEW, Z2)
IF(LEV.EQ.O) THEN
Zl - HTNEW(l)
SW1 - SWNEW(l)
ELSE
Zl - HTNEW(LEV)
SW1 - SWNEW(LEV)
ENDIF
ENDIF
C
C OF NO OBSERVATIONS, RETURN MISSING VALUE IF SIGMA-W
GSW00010
GSW00030
GSW00040
GSW00050
GSW00060
GSW00070
GSW00080
GSW00090
GSW00100
GSW00110
GSW00120
GSW00130
GSW00140
GSW00150
GSW00160
GSW00170
GSW00180
GSW00190
GSW00200
GSW00210
GSW00220
GSW00230
GSW00240
GSW00260
GSW00270
GSW00280
GSW00290
GSW00300
GS WO 03 10
GSW00320
GSW00330
GSW00348-
GSW00350
GSW00360
GSW00370
GSW00380
GSW00390
GSW00400
GSW00410
GSW00420
GSW00430
GSW00440
GSW00450
GSW00460
GSW00470
GSW00480
GSW00490
GSW00500
GSW00510
GSW00520
GSW00530
GSW00540
GSW00550
GSW00560
GSW00570
GSW00580
GSW00590
GSW00600
29
-------
IF(NNEW .EQ. 0) THEN GSW00620
GETSW » -9.99 GSW00630
RETURN GSW00640
ENDIF GSW00650
C GSW00660
C IN THIS SECTION, THERE IS AT LEAST ONE GOOD OBSERVATION GSW00670
C - GSW00630
C USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE CLOSEST OBS. GSW00690
C GSW00700
IF(LEV.GE.l .AND. LEV.LT.NNEW) THEN GSW00710
SW3 - SWNEW(LEV+1) GSW00720
Z3 - HTNEW(LEV-H) GSW00730
DX « SW3 - SW1 GSW00740
DZ - Z3 - Zl GSW00750
GETSW - SW1 + (Z2-Z1)*(DX/DZ) GSW00760
ELSE GSW00770
GETSW - SW1 GSW00780
ENDIF GSW00790
RETURN GSW00800
END GSW00810
30
-------
REAL FUNCTION GETTA( 22 )
C PURPOSE: THIS ROUTINE COMPUTES THE TEMPERATURE AT HEIGHT Z2.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT (M)
C RETURNED FUNCTION VALUE:
C GETTA REAL TEMPERATURE (DEG-K)
C
C I/O: NONE
C
C CALLING ROUTINES: HCRIT BULKFR
C
C EXTERNAL ROUTINES: KLOSE GETDTH
C
C INTRINSIC FUNCTIONS: ABS AINT AMAX1
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' PROFIL. CMN1
INCLUDE ' SFCMET . CMN '
C
C DEFINE ARGUMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
INTEGER LEV, N, NNEH, IEND
REAL TANEW(MAXLEV) , HTNEW(MAXLEV) , Zl, Z3, Tl, T3 ,
& DX, DZ, DTHDZ, DTDZ , DELZ, DELTAZ , Z, TAMISS
DATA TAMISS/ O.O/
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEH - 0
DO 100 N - 1,NHT
IF(TAHR(N) .LT. TAMISS ) GO TO 100
NNEW - NNEW + 1
TANEW(NNEW) - TAHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
IF (NNEW .EQ. 0) GO TO 200
LEV-KLOSE (HTNEW, NNEW, Z2 )
IF(LEV .EQ. 0) THEN
Zl - HTNEW(l)
Tl - TANEW(l)
ELSE
Zl-HTNEW(LEV)
Tl-TANEW(LEV)
ENDIF
C
C Zl IS MEASUREMENT HEIGHT CLOSEST TO BUT LESS THAN Z2.
C USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE PROFILING.
C
IFfLEV.GE.l .AND. LEV. LT. NNEW) THEN
GTA00010
GTA00030
GTA00040
GTA00050
GTA00060
GTA00070
GTA00080
GTA00090
GTA00100
GTA00110
GTA00120
GTA00130
GTA00140
GTA00150
GTA00160
GTA00170
GTA00180
GTA00190
GTA00200
GTA00210
GTA00220
GTA00240
GTA00250
GTA00260
GTA00270
GTA00280
GTA00290
GTA00300
GTA00310
GTA00320
GTA00330
GTA0034&-
GTA00350
GTA00360
GTA00370
GTA00380
GTA00390
GTA00400
GTA00410
GTA00420
GTA00430
GTA00440
GTA00450
GTA00460
GTA00470
GTA00480
GTA00490
GTA00500
GTA00510
GTA00520
GTA00530
GTA00540
GTA00550
GTA00560
GTA00570
GTA00580
GTA00590
GTA00600
31
-------
c
c
c
c
c
c
c
c
c
c
200
500
T3 - TANEW(LEV+1)
Z3 - HTNEW(LEV+1)
DX * T3 - Tl
D2 - 23 - Zl
GETTA - Tl + (Z2-Z1)*(DX/DZ)
RETURN
ENDIF
IF BOTH Zl AND Z2 ARE ABOVE XMH, USE THE (CONSTANT) VERTICAL
POTENTIAL TEMPERATURE GRADIENT TO EXTRAPOLATE
IF(Z1 .GT. XMH .AND. Z2 .GT. XMH) THEN
DTHDZ - GETDTH(Zl)
DTDZ - DTHDZ - 0.0098
GETTA " Tl + (Z2 - Zl) * DTDZ
RETURN
ENDIF
IF Zl OR Z2 IS BELOW XMH, VPTG MAY NOT BE CONSTANT WITH HEIGHT.
DIVIDE THE LAYER INTO SEVERAL LEVELS AND EXTRAPOLATE USING
DTHDZ: USE ONLY ONE LAYER FOR UNSTABLE CONDITIONS (DTHDZ-0);
MAKE LAYERS LESS THAN OR EQUAL TO 100 METERS OTHERWISE.
DELTAZ - ABS(Z2 - Zl)
IF(EL .LT. 0.0) THEN
DELZ - Z2 - Zl
ELSE
SIGN - (Z2 - Zl)/DELTAZ
X - AMAX1(1.0, AINT(DELTAZ/100.))
DELZ - DELTAZ * SIGN/X
ENDIF
Z - Zl
TAZ - Tl
IF( ABS(Z2-Z) .LT. ABS(DELZ) ) THEN
DZ - Z2 - Z
IEND - 1
ELSE
DZ - DELZ
IEND - 0
ENDIF
DTHZ - Z + 0.5 *
DELZ
IF( DTHZ .LT. 0.0 ) DTHZ
DTHDZ - GETDTH( DTHZ )
DTDZ - DTHDZ - 0.0098
TAZ - TAZ + DTDZ * DZ
IF(IEND.EQ.l) THEN
GETTA - TAZ
RETURN
ELSE
Z - Z + DELZ
GO TO 500
ENDIF
END
0.0
GTA00610
GTA00620
GTA00630
GTA00640
GTA00650
GTA00660
GTA00670
GTA00680
GTA00690
GTA00700
GTA00710
GTA00720
GTA00730
GTA00740
GTA00750
GTA00760
GTA00770
GTACI0780
GTA00790
GTA00800
GTA00810
GTA00820
GTA00830
GTA00840
GTA00850
GTA00860
GTA00870
GTA00880
GTA00890
GTA00900
GTA00910
GTA00920
GTA00930
GTA0094CT
GTA00950
GTA00960
GTA00970
GTA00980
GTA00990
GTA01000
GTA01010
GTA01020
GTA01030
GTA01040
GTA01050
GTA01060
GTA01070
GTA01080
GTA01090
GTA01100
GTA01110
GTA01120
GTA01130
GTA01140
32
-------
REAL FUNCTION GETUV( Z2, US2, SV2)
C PURPOSE: THIS ROUTINE COMPUTES THE VECTOR WIND SPEED AT HEIGHT 22.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT (M)
C US2 REAL SCALAR WIND SPEED AT HEIGHT Z2, M/SEC
C SV2 REAL SIGMA-V AT HEIGHT 22, M/SEC
C RETURNED FUNCTION VALUE:
C GETUV REAL WIND SPEED (M/S)
C
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: KLOSE GETSV GETSW
C
C INTRINSIC FUNCTIONS: SIN SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' SFCMET . CMN '
INCLUDE 'PROFIL. CMN'
C
C DEFINE ARGUMETS
REAL 22, US2, SV2
C
C DEFINE LOCAL VARIABLES
REAL UV1, Zl, UVNEW(MAXLEV),
2 HTNEW(MAXLEV) , UV3 , UVMISS
INTEGER LEV
DATA UVMISS/ O.O/
C
IF(US2 .EQ. UVMISS ) THEN
GETUV - 0.0
RETURN
ENDIF
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEW - 0
DO 100 N - 1,NHT
IF(UVHR(N) .LT. UVMISS ) GO TO 100
NNEW - NNEW + 1
UVNEW(NNEW) - UVHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
IF(NNEW.EQ.O) THEN
GETUV - US2
RETURN
ENDIF
LEV-KLOSE(HTNEW,NNEW,Z2)
IF (LEV .EQ. 0) THEN
Zl - HTNEW(l)
GUV00010
GUV00030
GUV00040
GUV00050
GUV00060
GUV00070
GUV00080
GUV00090
GUV00100
GUV00110
GUV00120
GUV00130
GUV00140
GUV00150
GUV00160
GUV00170
GUV00180
GUV00190
GUV00200
GUV00210
GUV00220
GUV00230
GUV00240
GUV00260
GUV00270
GUV00280
GUV00290
GUV00300
GUV00310
GUV00320
GUV00330
GUV0034CL.
GUV00350
GUV00360
GUV00370
GUV00380
GUV00390
GUV00400
GUV00410
GUV00420
GUV00430
GUV00440
GUV00450
GUV00460
GUV00470
GUV00480
GUV00490
GUV00500
GUV00510
GUV00520
GUV00530
GUV00540
GUV00550
GUV00560
GUV00570
GUV00580
GUV00590
GUV00600
33
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
UV1 =• UVNEW(l)
ELSE
Zl-HTNEW(LEV)
UVl-UVNEW(LEV)
ENDIF
Zl IS MEASUREMENT HEIGHT CLOSEST TO BUT LESS THAN Z2.
USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE PROFILING.
IF(LEV.GE.l .AND. LEV.LT.NNEW) THEN
UV3 - UVNEW(LEV+1)
Z3 - HTNEW(LEV+1)
DX - UV3 - UV1
DZ - Z3 - Zl
GETUV - UV1 + (Z2-Z1)*(DX/DZ)
RETURN
ENDIF
IF BOTH Zl AND 22 ARE ABOVE XMH, USE THE MEASUREMENT WITHOUT
SCALING.
IF(Z1 .GT. XMH .AND. Z2 .GT. XMH) THEN
GETUV - UV1
RETURN
ENDIF
IN THIS SECTION, SCALE UV WITHIN MIXED LAYER (ADJUST Zl AND Z2
TO BE NO MORE THAN XMH).
SCALE UV(Z1) TO UV(Z2) BY FIRST SCALING SIGMA-THETA TO Z2
Z3 - Zl
24 - 22
IF(Z3 .GT. XMH) Z3 - XMH
IF(Z4 .GT. XMH) Z4 - .XMH
SV1 - GETSV(Z3)
US1 • GETWS(Z3)
SIGTH1 - SV1/UV1
SIGTH2 - SIGTH1 * SV2/SV1 * US1/US2
COMPUTE SIGMA-V FROM SIGMA-THETA USING VECTOR WIND SPEED.
GET VECTOR SPEED FROM SCALAR SPEED AND SIGMA-THETA USING
YAMARTINO'S (1984) RELATIONSHIP.
EPS - SIN(SIGTH2 * (1.0 - 0.073864*SIGTH2))
GETUV - US2 * SQRT(1.0 - EPS*EPS)
RETURN
END
GUV00610
GUV00620
GUV00630
GUV00640
GUV00650
GUV00660
GUV00670
GUV00680
GUV00690
GUV00700
GUV00710
GUV00720
GUV00730
GUV00740
GUV00750
GUV00760
GUV00770
GUV00780
GUV00790
GUV00800
GUV00810
GUV00820
GUV00830
GUV00840
GUV00850
GUV00860
GUV00870
GUV00880
GUV00890
GUV00900
GUV00910
GUV00920
GUV00930
GUV00940—
GUV00950
GUV00960
GUV00970
GUV00980
GUV00990
GUV01000
GUV01010
GUV01020
GUV01030
GUV01040
GUV01050
GUV01060
GUV01070
GUV01080
-------
REAL FUNCTION GETWD( Z2 )
C PURPOSE: THIS ROUTINE COMPUTES THE WIND DIRECTION AT HEIGHT Z2.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT (M)
C
C RETURNED FUNCTION VALUE:
C GETWD REAL WIND DIRECTION (DEG)
C
C I/O: NONE
C
C CALLING ROUTINES: PLAVG
C
C EXTERNAL ROUTINES: KLOSE DELWD
C
C INTRINSIC FUNCTIONS: ABS ALOG AMAX1 ATAN SQRT
C
C INCLUDE FILES: P ARAMS. INC
C
C COMMON BLOCKS: SFCMET PROFIL
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' SFCMET . CMN '
INCLUDE ' PROFIL . CMN '
INCLUDE 'PARAMS. CMN1
C
C DEFINE ARGUMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
REAL R, SQR, A, B, UGDUS,
1 ANG, DELI, DEL2, DELANG, WD1, Zl,
2 WDNEW(MAXLEV) , HTNEW(MAXLEV) , WDMISS
INTEGER LEV, N, NNEW, NO
DATA WDMISS/ O.O/, NO/0/
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEW - 0
DO 100 N - 1,NHT
IF( WDHR(N) .LT. WDMISS ) GO TO 100
NNEW - NNEW + 1
WDNEW(NNEW) - WDHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
IF(NNEW.EQ.O) THEN
GETWD - 0.
RETURN
ENDIF
C
C GET NEAREST LEVEL OF DATA LESS THAN HEIGHT Z2
C
LEV - KLOSE (HTNEW, NNEW, Z2)
IF (LEV .EQ. 0) THEN
Zl - HTNEW(l)
WD1 - WDNEW(l)
GWD00010
GWD00030
GWD00040
GWD00050
GWD00060
GWD00070
GWD00080
GWD00090
GWD00100
GWD00110
GWD00120
GWD00130
GWD00140
GWD00150
GWD00160
GWD00170
GWD00180
GWD00190
GWD00200
GWD00210
GWD00220
GWD00230
GWD00250
GWD00260
GWD00270
GWD00280
GWD00290
GWD00300
GWD00310
GWD00320
GWD00330
GWD00340"
GWD00350
GWD00360
GWD00370
GWD00380
GWD00390
GWD00400
GWD00410
GWD00420
GWD00430
GWD00440
GWD00450
GWD00460
GWD00470
GWD00480
GWD00490
GWD00500
GWD00510
GWD00520
GWD00530
GWD00540
GWD00550
GWD00560
GWD00570
GWD00580
GWDOOS90
GWD00600
35
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
ELSE
Zl - HTNEW(LEV)
WD1 - WDNEW(LEV)
ENDIF
USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE PROFILING
IF(L£V.GE.l .AND. LEV.LT.NNEW) THEN
WD3 - WDNEW(LEV+1)
Z3 -.HTNEW(LEV+1)
DX - DELWD(WD1,WD3)
DZ - Z3-Z1
GETWD » WD1 + (Z2-Z1)*(DX/DZ)
IF(GETWD .LE. 0.0) THEN
GETWD - 360.0+GETWD
ELSE IF(GETWD .GT. 360.0) THEN
GETWD - GETWD-360.0
ENDIF
RETURN
ENDIF
IF BOTH Zl AND 22 ARE ABOVE XMH, USE OBSERVATION AT Zl WITHOUT
SCALING.
IF(Z1 .GT. XMH .AND. Z2 .GT. XMH) THEN
GETWD » WD1
RETURN
ENDIF
NO SCALING OF WIND DIRECTION WITH HEIGHT
IF(IWD .EQ. NO) THEN
GETWD - WD1
RETURN
ENDIF
DO SCALING IF EITHER Zl OR Z2 IS BELOW XMH — NO CHANGE IN WIND
DIRECTION IS ASSUMED FOR HEIGHTS ABOVE XMH.
DETERMINE SURFACE BACKING ANGLE (FROM TENNEKES, 1981).
SEE EQN 7 OF CTDM USER'S GUIDE.
R - XMH/EL
SQR - SQRT(ABS(R))
DETERMINE THE RESISTANCE STABILITY FUNCTION, A
IF(R .LT. -25.0) THEN
A - 3.9
ELSE IF(R .LE. 0.0) THEN
A - 0.79 * SQR
ELSE
A - -4.17 * SQR
ENDIF
DETERMINE THE ANGLE STABILITY FUNCTION, B
IF(R .LT. -50.0) THEN
B - 1.2
ELSE IF(R .LE. 10.0) THEN
B - 1.2 + SQRT(R+50.0) * 0.491
GWD00610
GWD00620
GWD00630
GWD00640
GWD00650
GWD00660
GWD00670
GWD006SO
GWD00690
GWD00700
GWD00710
GWD00720
GWD00730
GWD00740
GWD00750
GWD00760
GWD00770
GWD00780
GWD00790
GWD00800
GWD00810
GWD00820
GWD00830
GWD00840
GWD00850
GWD00860
GWD00870
GWD00880
GWD00890
GWD00900
GWD00910
GWD00920
GWD00930
GWD00940-
GWD00950
GWD00960
GWD00970
GWD00980
GWD00990
GWD01000
GND01010
GWD01020
GWD01030
GWD01040
GWD01050
GWD01060
GWD01070
GWD01080
GWD01090
GWD01100
GWD01110
GWD01120
GWD01130
GWD01140
GWD01150
GWD01160
GWD01170
GWD01180
GWD01190
GWD01200
36
-------
ELSE IF(R .LE. 50.0) THEN GWD01210
B - 5.0 + SQRT(R-IO.O) * 3.175 GWD01220
ELSE GWD01230
B- - 25.0 GWD01240
ENDIF GWD01250
UGDUS - (ALOG(USTARO/(CORIOL*ZO)) - A)/0.4 GWD01260
ANG - ATAN(B/(0.4*UGDUS)) * 57.29578 GWD01270
C - GWD01280
C SIMULATE BACKING WITH HEIGHT USING A LINEAR RELATION GWD01290
C GWD01300
DELI - AMAX1(0.0,1.0 - Zl/XMH) GWD01310
DEL2 - AMAX1(0.0,1.0 - Z2/XMH) GWD01320
DELANG - ANG * (DELI - DEL2) GWD01330
GETWD - WD1 + DELANG GWD01340
IF(GETWD .GT. 360.0) THEN GWD01350
GETWD - GETWD - 360.0 GWD01360
ELSE IF(GETWD .LT. 0.0) THEN GWD01370
GETWD - GETWD + 360.0 GWD01380
ENDIF GWD01390
C GWD01400
RETURN GWD01410
END GWD01420
ff
37
-------
REAL FUNCTION GETWS( Z2)
C PURPOSE: THIS ROUTINE COMPUTES THE WIND SPEED AT HEIGHT Z2.
C
C ARGUMENTS
C PASSED:
C Z2 REAL HEIGHT (M)
C RETURNED FUNCTION VALUE:
C GETWS REAL WIND SPEED (M/S)
C
C I/O: NONE
C
C CALLING ROUTINES: BULKFR GETUV HCRIT PLAVG SEQMOD SRISE URISE
C
C EXTERNAL ROUTINES: KLOSE
C
C INTRINSIC FUNCTIONS: ALOG ATAN
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: SFCMET PROFIL
C
C
INCLUDE 'PARAMS.INC'
INCLUDE ' SFCMET. CMN'
INCLUDE 'PROFIL. CMN'
C
C DEFINE ARGUEMENTS
REAL Z2
C
C DEFINE LOCAL VARIABLES
INTEGER LEV, N, NNEW
REAL Ul, Zl, Z1L, Z2L, Z1ZO, Z2ZO,
1 CAP, PSIU1, PSIU2, X, WSNEW(MAXLEV) ,
2 HTNEW(MAXLEV), WSMISS
DATA WSMISS/ O.O/
C
C EXAMINE DATA AND SELECT ONLY NONMISSING VALUES
C
NNEW - 0
DO 100 N - 1,NHT
IF(WSHR(N) .LT. WSMISS ) GO TO 100
NNEW - NNEW 4- 1
WSNEW(NNEW) - WSHR(N)
HTNEW(NNEW) - HT(N)
100 CONTINUE
IF (NNEW .EQ. 0) GO TO 200
LEV-KLOSE (HTNEW , NNEW , Z2 )
IF(LEV .EQ. 0) THEN
Zl - HTNEW(l)
Ul - WSNEW(l)
ELSE
Zl - HTNEW(LEV)
Ul - WSNEW(LEV)
ENDIF
C
C Zl IS MEASUREMENT HEIGHT CLOSEST TO BUT LESS THAN 22.
C USE INTERPOLATION IF POSSIBLE; OTHERWISE, USE PROFILING.
C
GWS00010
GWS00030
GWS00040
GWS00050
GWS00060
GWS00070
GWSOOOSO
GWSCI0090
GWS00100
GWS00110
GWS00120
GWS00130
GWS00140
GWS00150
GWS00160
GWS00170
GWS00180
GWS00190
GWS00200
GWS00210
GWS00220
GWS00240
GWS00250
GWS00260
GWS00270
GWS00280
GWS00290
GWS00300
GWS00310
GWS00320
GWS00330
GWS0034Q—
GWS00350
GWS00360
GWS00370
GWS00380
GWS00390
GWS00400
GWS00410
GWS00420
GWS00430
GWS00440
GWSOCI450
GWS00460
GWS00470
GWS00480
GWS00490
GWS00500
GWS00510
GWS00520
GWS00530
GWS00540
GWS00550
GWS00560
GWS00570
GWS00580
GWS00590
GWS00600
if
38
-------
c
c
c
c
c
c
c
c
c
200
IF(LEV.GE.l .AND. LEV.LT.NNEW) THEN
U3 - WSNEW(LEV+1)
Z3 - HTNEW(LEV+1)
DX - U3 - Ul
DZ - 23 - Zl
GETWS -01+ (Z2-Z1)*(DX/DZ)
RETURN
ENDIF
IF BOTH Z_l AND Z2 ARE ABOVE XMH, USE THE MEASUREMENT WITHOUT
SCALING.
IF(Z1 .GT. XMH .AND. Z2 .GT. XMH) THEN
GETWS - Ul
RETURN
ENDIF
USE PROFILE EQUATIONS IF EITHER Zl OR Z2 IS BELOW MXH
(NO WIND SPEED INCREASE IS ASSUMED ABOVE XMH)
Z1L - Zl/EL
Z1ZO - ALOG(Z1/ZO)
IF(Z1L .LT. 0.0) THEN
" CAP - 0.1 * XMH
IF(Z1 .GT. CAP) THEN
Z1L - CAP/EL
Z1ZO - ALOG(CAP/ZO)
ENDIF
X - (1.0 - 15.0*Z1L)**0.25
PSIU1 - 2.0 * ALOG(0.5*(1.0+X)) + ALOG(0.5*(1.0+X*X)) -
2.0*ATAN(X) + 1.5707963
ELSE
CAP - XMH
IF(Z1 .GT. CAP) THEN
Z1L - CAP/EL
Z1ZO - ALOG(CAP/ZO)
ENDIF
PSIU1 - -4.7*Z1L
ENDIF
Z3 - AMAX1(ZO,Z2)
Z2L - Z3/EL
Z2ZO - ALOG(Z3/ZO)
IF(Z2L .LT. 0.0) THEN
CAP - 0.1 * XMH
IF(Z3 .GT. CAP) THEN
Z2L - CAP/EL
Z2ZO - ALOG(CAP/ZO)
ENDIF
X - (1.0 - 15.0*Z2L)**0.25
PSIO2 - 2.0 * ALOG(0.5*(1.0+X))
2.0*ATAN(X) + 1.5707963
ELSE
CAP - XMH
IF(Z3 .GT. CAP) THEN
Z2L - CAP/EL
Z2ZO - ALOG(CAP/ZO)
ENDIF
PSIU2 - -4.7*Z2L
+ ALOG(0.5*(1.0+X*X)) -
GWS00610
GWS00620
GWS00630
GWS00640
GWS00650
GWS00660
GWS00670
GWS00680
GWS00690
GWS00700
GWS00710
GWS00720
GWS00730
GWSOO/40
GWS00750
GWS00760
GWS00770
GWS00780
GWS00790
GWS00800
GWS00810
GWS00820
GWS00830
GWS00840
GWS00850
GWS00860
GWS00870
GWS00880
GWS00890
GWS00900
GWS00910
GWS00920
GWS00930
GWS00940*~
GWS00950
GWS00960
GWS00970
GWS00980
GWS00990
GWS01000
GWS01010
GWS01020
GWS01030
GWS01040
GWS01050
GWS01060
GWS01070
GWS01080
GWS01090
GWS01100
GWS01110
GWS01120
GWS01130
GWS01140
GWS01150
GWS01160
GWS01170
GWS01180
GWS01190
GWS01200
39
-------
ENDIF GWS01210
GWS01220
IF(NNEW.EQ.O) THEN GWS01230
GETWS = (USTARO/0.4) * (Z2ZO - PSIU2) GWS01240
EI-SE GWS01250
GETWS - Ul * (Z2ZO - PSIU2)/(Z1ZO - PSIU1) GWS01260
ENDIF GWS01270
GWS01280
RETURN GWS01290
END . GWS01300
-------
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
10
REAL FUNCTION HCRIT(HHILL)
PURPOSE: COMPUTE CRITICAL DIVIDING STREAMLINE HEIGHT FOR CURRENT HILL
LIMITATIONS:
ARGUMENTS :
PASSED:
HHILL REAL HEIGHT OF TOP OF HILL [METERS]
RETURNED FUNCTION VALUE:
HCRIT REAL CRITICAL DIVIDING STREAMLINE HEIGHT [METERS]
I/O: NONE
CALLING ROUTINES: SEQMOD
EXTERNAL ROUTINES: KLOSE GETTA GETWS
INTRINSIC FUNCTIONS: SQRT
INCLUDE FILES: PARAMS.INC
COMMON BLOCKS: PROFIL.CMN SFCMET.CMN
INCLUDE 'PARAMS.INC'
INCLUDE 'PROFIL.CMN'
INCLUDE 'SFCMET.CMN'
DEFINE ARGUMENTS
REAL HHILL
DEFINE LOCAL VARIABLES
REAL LS (MAXLEV) , RS (MAXLEV), WSHC(MAXLEV) , TAHC(MAXLEV) ,
& DTHHC (MAXLEV) , ZZ (MAXLEV) , XN2 (MAXLEV) , N2 , DWS, DWS2
REAL ZMIX(3)
INTEGER IADD
DATA G/9.8/
COMPUTE HEIGHTS WITHIN THE SURFACE LAYER FOR ADDITIONAL LAYER
RESOLUTION FOR COMPUTING HCRIT. IF THE LOWEST MEASUREMENT
HEIGHT IS ABOVE ANY OF THESE HEIGHTS, ADD TO' THE LIST OF
HEIGHTS FOR LAYER-BY-LAYER ANALYSIS.
ADD LAYERS AT 0.25, 0.50, AND 1.0 XMH
ZMIX(l) - 0.25 * XMH
ZMIX(2) - 0.50 * XMH
ZMIX(3) - 1.00 * XMH
IADD - 1
ZZ(1) - 1.0
INSERT NEW LEVELS IN MEASUREMENT HEIGHT ARRAY
DO 100 I - 1,3
IF(ZMIX(I) .LT. HT(1)) THEN
IADD - I + 1
ZZ(IADD) - ZMIX(I)
ENDIF
10 CONTINUE
K - KLOSE (HT, NOT, HHILL)
HCR00010
— w<^pfifirt o n
nv»i\w v \j <, \j
HCR00030
HCR00040
HCR00050
HCR00060
HCR00070
HCR00080
HCR00090
HCR00100
HCR00110
HCR00120
HCR00130
HCR00140
HCR00150
HCR00160
HCR00170
HCR00180
HCR00190
HCR00200
HCR00210
HCR00220
HCR00230
HCR00240
tx/^on no i?n
•nwKUU^OU
HCR00260
HCR00270
HCR00280
HCR00290
HCR00300
HCR00310
HCR00320
HCR00330
HCR00346-
HCR00350
HCR00360
HCR00370
HCR00380
HCR00390
HCR00400
HCR00410
HCR00420
HCR00430
HCR00440
HCR00450
HCR00460
HCR00470
HCR00480
HCR00490
HCR00500
HCR00510
HCR00520
HCR00530
HCR00540
HCR00550
HCR00560
HCR00570
HCR00580
HCR00590
HCR00600
-------
200
C
C
C
400
C
C
C
C
C
NLEV - K + IADD + 1
ZZ(NLEV) = HHILL
DO 200 IK = 1, K
ZZ(IK+IADD)
CONTINUE
HT(IK)
600
C
C
C
C
800
C
C
C
C
C
C
C
C
C
COMPUTE LEFT SIDE OF EQN 32 IN USER'S GUIDE
DO 400 "ML - 1, NLEV
WSHC(NL) - GETWS(ZZ(NL))
LS(NL) - 0.5 * WSHC(NL) * WSHC(NL)
CONTINUE
COMPUTE RIGHT SIDE OF EQN 32 FOR EACH LAYER, INTEGRATING
DOWNWARD IN LAYERS FROM THE HILL TOP. A LINEAR CHANGE IN
METEOROLOGICAL VARIABLES IS ASSUMED IN EACH LAYER.
RS(NLEV) - 0.0
DO 600 NL - NLEV-1, 1, -1
ZMID - 0.5 * (ZZ(NL+1)+Z2(NL))
TAHC(NL) - GETTA(ZMID)
DTHHC(NL) - GETDTH(ZMID)
XN2(NL) - G / TAHC(NL) * DTHHC(NL)
RS(NL) - RS(NL+1) +
& XN2(NL) * ((HHILL-ZMID) * (ZZ(NL+1)-ZZ(NL) ))
CONTINUE
FIND LAYERS WHERE EQN 32 IS SATISFIED; THE LOWEST SUCH LAYER IS
SAVED IN THE "IT" VARIABLE
DO 800 NL - NLEV, 1, -1
IF(LS(NL) .GE. RS(NL)) IT - NL
CONTINUE
INTERPOLATE TO GET HC, ASSUMING A LINEAR CHANGE OF VARIABLES
WITHIN A LAYER; RESULT IS A QUADRATIC EQN FOR HC
DWS IS WIND SPEED SHEAR; N2 IS THE BRUNT-VAISALA FREQUENCY.
IF(IT .GT. 1) THEN
IB - IT - 1
HTOP - ZZ(IT)
HBOT - ZZ(IB)
DWS - (WSHC(IT)-WSHC(IB))/(HTOP-HBOT)
DWS2 - DWS * DWS
M2 - XN2(IB)
SOLVE QUADRATIC EQN
A - 0.5 * (N2 - DWS2)
B - (HTOP*DWS2 - WSHC(IT)*DWS - N2*HHILL)
C - N2*HHILL*HTOP -
& 0.5*(N2*HTOP*HTOP) -
& 0.5*(DWS2*HTOP*HTOP) +
& WSHC(IT)*DWS*HTOP - (LS(IT)-RS(IT))
B2 - B * B
AC4 - 4.0 * A * C
DETER • SQRT(B2-AC4)
HCRIT - (-B - DETER)/(2.*A)
ELSE
HCR00610
HCR00620
HCR00630
HCR00640
HCR00650
HCR00660
HCR00670
HCR00680
HCR00690
HCR00700
HCR00710
HCR00720
HCR00730
HCR00740
HCR00750
HCR00760
HCR00770
HCR00780
HCR00790
HCR00800
HCR00810
HCR00820
HCR00830
HCR00840
HCR00850
HCR00860
HCR00870
HCR00880
HCR00890
HCR00900
HCR00910
HCR00920
HCR00930
HCR0094-9-
HCR00950
HCR00960
HCR00970
HCR00980
HCR00990
HCR01000
HCR01010
HCR01020
HCR01030
HCR01040
HCR01050
HCR01060
HCR01070
HCROL080
HCR01090
HCR01100
HCR01110
HCR01120
HCR01130
HCR01140
HCROI150
HCR01160
HCR01170
HCR01180
HCR01190
HCR01200
42
-------
HCRIT « 0.0 HCR01210
ENDIF HCR01220
RETURN HCR01230
END HCR01240
-------
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
REAL FUNCTION HILHGT(X,Y)
DESCRIPTION: COMPUTES THE FRACTIONAL HILL HEIGHT AT
THE POSITION (X,Y) FOR A ROTATED GAUSSIAN HILL.
ARGUMENTS :
PASSED:
X,Y REAL LOCATION AT WHICH HEIGHT IS NEEDED (M)
I/O: NONE
CALLING ROUTINES: FLOW PATH
EXTERNAL ROUTINES: NONE
INTRINSIC FUNCTIONS: EXP
INCLUDE FILES: PARAMS.INC
COMMON BLOCKS: PASL
INCLUDE 'PARAMS.INC'
INCLUDE 'PASL.CMN'
DEFINE ARGUMENTS
REAL X, Y
DEFINE LOCAL VARIABLES
REAL Q, XDLX, YDLY
EQN. A-25
XDLX - X / LX
YDLY - Y / LY
Q - XDLX*XDLX + YDLY*YDLY + 2.0*GAM*X*Y
NOTE THAT HILROT PROVIDES CROSSTERM GAM FOR A ROTATED HILL
IF(Q .GT. 30.) Q - 30.
HILHGT - EXP(-Q)
«
RETURN
END
HHT00010
HHT00030
HHT00040
HHT00050
HHT00060
HHT00070
HHT00080
HHT00090
HHT00100
HHT00110
HHT00120
HHT00130
HHT00140
HHT00150
HHT00160
HHT00170
HHT00180
HHT00190
HHT00200
HHT00210
HHT00230
HHT00240
HHT00250
HHT00260
HHT00270
HHT00280
HHT00290
HHT00300
HHT00310
HHT00320
HHT00330
HHTOCI34e-
HHT00350
HHT00360
HHT00370
HHT00380
HHT00390
HHT00400
HHT00410
HHT00420
II
-------
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
SUBROUTINE HILROT( AH, BH, PSI )
PURPOSE: COMPUTES THE NEEDED LENGTH SCALES LX AND LY AND THE
FACTOR GAM FOR A GAUSSIAN HILL HAVING MAJOR AXIS AH, MINOR AXIS
BH, AND ROTATED CCW BY AN ANGLE PSI.
WHEN PSI=0 THE MINOR AXIS IS ORIENTED ALONG THE X-AXIS (OR FLOW
DIRECTION) AND THE MAJOR AXIS LIES ALONG THE Y-AXIS.
ARGUMENTS :
PASSED:
AH, BH REAL MAJOR AND MINOR HILL SEMI -AXIS LENGTHS (M)
PSI REAL ANGLE OF ROTATION (RADIANS)
RETURNED: NONE
I/O: NONE
CALLING ROUTINES: LIFTIN
EXTERNAL ROUTINES: NONE
INTRINSIC FUNCTIONS: COS SIN SQRT
INCLUDE FILES: PARAMS.INC
COMMON BLOCKS: PASL
INCLUDE ' PARAMS . INC '
INCLUDE 'PASL.CMN'
DEFINE ARGUMENTS
REAL AH, BH, PSI
DEFINE LOCAL VARIABLES
REAL CPSI, CPSI2, LAI2, LBI2, LXI2, LYI2, SPSI, SPSI2
EQN. A-25
CPSI - COS (PSI)
CPSI2 - CPSI*CPSI
SPSI - SIN (PSI)
SPSI2 - SPSI*SPSI
LAI2 - 1.0 / (AH*AH)
LBI2 - 1.0 / (BH*BH)
GAM - (LBI2-LAI2)*CPSI*SPSI
LXI2 - CPSI2*LBI2 + SPSI2*LAI2
LX - 1.0 / SQRT(LXI2)
LYI2 - CPSI2*LAI2 + SPSI2*LBI2
LY - 1.0 / SQRT(LYI2)
RETURN
END
HRT00010
Tj^mrt f\ f\ O rt
— rlKi 00020
HRT00030
HRT00040
HRT00050
HRT00060
HRT00070
HRT00080
HRT00090
HRT00100
HRT00110
HRT00120
HRT00130
HRT00140
HRT00150
HRT00160
HRT00170
HRT00180
HRT00190
HRT00200
HRT00210
HRT00220
HRT00230
HRT00240
HRT00250
HRT00260
UWTlArtO"7r\
• I1KTQU2 /O
HRT00280
HRT00290
HRT00300
HRT00310
HRT00320
HRT00330
HRT00340
HRT00350"
HRT00360
HRT00370
HRT00380
HRT00390
HRT00400
HRT00410
HRT00420
HRT00430
HRT00440
HRT00450
HRT00460
HRT00470
HRT00480
HRT00490
HRT00500
HRT00510
HRT00520
HRT00530
-------
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
SUBROUTINE INPAR
PURPOSE:
THIS SUBROUTINE READS AND PRINTS THE PROGRAM I/O SWITCHES,
PROGRAM CONVERSION FACTORS AND CONSTANTS, AND OTHER
MISCELLANEOUS SWITCHES. THESE VALUES ARE SAVED IN PARAMS.CMN.
ARGUMENTS :
PASSED: NONE-
RETURNED: NONE
I/O:
INPUT FROM UNIT 5:
LINE 1: SWITCHES (0 OR 1) FOR SEVERAL PROGRAM OPTIONS
LINE 2: HORI2. AND VERT. CONVERSION FACTORS, LATITUDE AND
LONGITUDE OF SITE, TIME ZONE, POLLUTANT f
OUTPUT TO UNIT 6:
PRINTOUT OF VALUES OF SWITCHES AND PARAMETERS READ IN
CALLING PROGRAM: CTDM (MAIN)
EXTERNALS: PAGE, TOPN
INCLUDE FILES: NONE
COMMON BLOCKS: 10, PARAMS
INCLUDE ' IO . CMN '
INCLUDE ' PARAMS . CMN '
DEFINE LOCAL VARIABLES
INTEGER NO , YES
REAL DTR, OMEGA, DUMMY (1)
DATA NO/0/
DATA YES/ I/
READ INPUT PARAMETERS
READ (IN,*) ICASE, ITOPN, ICONC, IMIX,
1 IWS1, ISIGV, IWD, ICHIQ
READ(IN,*) HORIZ, VERT, ALAT, ALONG, TZONE, IPOL
DEFAULT INPUTS
IF (ICASE .NE. NO .AND. ICASE .NE. YES) ICASE = NO
IF (ITOPN .NE. NO .AND. ITOPN .NE. YES) ITOPN - YES
IF(ICONC .LT. 0 .AND. ICONC. GT. 3) ICONC - 0
WRITE INPUT PARAMETERS
WRITE (IOUT, 6010) ICASE, ITOPN, ICONC
WRITE (IOUT, 6020) IMIX, IWS1, ISIGV, IWD, ICHIQ
WRITE (IOUT, 6040) HORIZ, VERT
WRITE (IOUT, 6050) ALAT, ALONG, TZONE, IPOL
INITIALIZE TOP N ARRAYS
IF(ITOPN .EQ. YES) CALL TOPN (DUMMY, 1, -1, ' ')
INP00010
• INP00020
INP00030
INP00040
INP00050
INP00060
INP00070
INP00080
INP00090
INP00100
INP00110
INP00120
INP00130
INP00140
INP00150
INP00160
INP00170
INP00180
INP00190
INP00200
INP00210
INP00220
INP00230
INP00240
INP00250
INP00260
INP00270
INP00280
INP00300
INP00310
INP00320
INP00330
INP0034&-
INP00350
INP00360
INP00370
INP00380
INP00390
INP00400
INP00410
INP00420
INP00430
INP00440
INP00450
INP00460
INP00470
INP00480
INPOQ490
INP00500
INP00510
INP00520
INP00530
INP00540
INP00550
INP00560
INP00570
INP00580
INP00590
INP00600
-------
C
C
c
6010
6020
6040
6050
1
2
3
4
5
6
7
1
2
3
4
5
6
6
A
B
C
D
1
2
1
2
3
NEGATIVE USED BY WRITIT TO INDICATE FIRST TIME THROUGH
IF(ICONC .EQ. 3) ICONC = -3
OMEGA=7.292E-5
DTR=0.01745329
CORIOL=2.0*OMEGA*SIN(ALAT*DTR)
RETURN
FORMAT(/////,10X,'INPUT/OUTPUT SWITCHES (1 = USE THIS OPTION,
•0 - DO NOT USE OPTION )',//,10X,
'ICASE: INCLUDE CASE-STUDY PRINTOUT1,
T78,I1,/,10X,
'ITCPN: CREATE TOP 4 TABLE AT END OF RUN1,
T78,I1,/,10X,
'ICONC: CONCENTRATION OUTPUT: 0 - NONE, 1 - BINARY, ',
•2/3 - TEXT',T78,I1,/)
FORMAT(/,10X,'INTERNAL PROGRAM SWITCHES',//,10X,
'IMIX: (IF 1, USE ON-SITE MIXING HEIGHT OBSERVATIONS ',/
15X,' (OFF-SITE IF NOT AVAILABLE); IF 0, VICA VERSA)1,
T78,I1,/,10X,
'IWS1: (IF 1, SET MINIMUM WIND SPEED TO 1.0 M/S)
T78,I1,/,10X,
'ISIGV: (HORIZ. TURB. INTENSITY DATA (0-SIGMA-THETA ',
'1-SIGMA-V)',T78,I1,/,10X,
'IWD: (IF 1, SCALE WIND DIRECTION WITH HEIGHT)
T78,I1,/,10X,
'ICHIQ: (IF 1, MODEL OUTPUTS CHI/Q; OTHERWISE IT OUTPUTS CHI)
FORMAT (/,! OX, 'FOR HORIZONTAL SCALE, MULTIPLY USER UNITS BY
F10.4,1 TO GET METERS. ' ,/,10X, 'FOR ELEVATION, ',
'MULTIPLY USER UNITS BY ',F10.4,' TO GET METERS.',/)
FORMAT (10X, 'SITE LATITUDE (> 0 IF NORTH) - ',F6.3,/,
10X,'SITE LONGITUDE (> 0 IF WEST) - ',F7.3,/,
10X,'SITE TIME ZONE (> 0 IF WEST) - ',F5.0,/,
10X, 'POLLUTANT I (FOR HOURLY EMISSIONS) - ',14)
END
INP00610
INP00620
INP00630
INP00640
INP00650
INP00660
INP00670
INP00680
INP00690
1,INP00700
INP00710
INP00720
INP00730
INP00740
INP00750
INP00760
INP00770
INP00780
INP00790
INP00800
INP00810
,INP00820
INP00830
INP00840
INP00850
,INP00860
INP00870
,INP00880
INP00890
INP00900
INP00910
INP00920
INP00930
INP0094_0_
INP00950
INP00960
INP00970
INP00980
47
-------
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 INPEMS
PURPOSE: THIS ROUTINE READS VARIABLE EMISSIONS PARAMETERS AND UPDATES
THE STACKS
COMMON BLOCK.
LIMITATIONS: NO CHECKING FOR VALID INPUT DATA IS DONE IN THIS ROUTINE
HOWEVER, A
CONSISTENCY
"~
ARGUMENTS: NONE
-
I/O:
INPUT:
UNIT-INEMIS (FREE
VARIABLE
JYR
JMO
JDY
JHR
IS
TS
vs
QS(1)
QS(2)
QS(3)
QS(4)
LINE 2 IS REPEATED
TIME AND STACK NUMBER CHECK IS MADE FOR
WITH WHAT THE MODEL EXPECTS TO BE READ IN.
FORMAT)
DESCRIPTION
YEAR (00-99)
MONTH
DAY OF THE MONTH
HOUR (TIME AT END OF THE HOUR)
STACK NUMBER
STACK GAS TEMPERATURE (DEG K)
STACK GAS EXIT VELOCITY (M/SEC)
EMISSION RATE FOR POLL. 11 (G/S)
EMISSION RATE FOR POLL. #2 (G/S)
EMISSION RATE FOR POLL. |3 (G/S)
EMISSION RATE FOR POLL. #4 (G/S)
FOR EACH STACK WHOSE EMISSIONS PARAMETERS
IEM00010
IEM00030
IEM00040
IEM00050
.IEM00060
IEM00070
IEM00080
IEM00090
IEM00100
IEM00110
IEM00120
IEM00130
IEM00140
IEM00150
IEM00160
IEM00170
IEM00180
IEM00190
IEM00200
IEM00210
IEM00220
IEM00230
IEM00240
IEM00250
IEM00260
IEM00270
IEM00280
CHANGE IN THIS HOUR. A BLANK LINE OR IS-0 TERMINATES THE READINGIEM00290
OF EMISSIONS DATA
FOR THIS HOUR.
IEM00300
IEM00310
C CALLING ROUTINES: SEQMOD IEM00320
C IEM00330
C EXTERNALS ROUTINES: NONE IEM00340_
C IEM00350
C INCLUDE FILES: PARAMS.INC
C
C
C COMMON BLOCKS: IO STACKS
TIME PARAMS VARS
INCLUDE
INCLUDE
INCLUDE
INCLUDE
INCLUDE
INCLUDE
'PARAMS.INC'
'IO.CMH'
1 STACKS. CMN'
•TIME.CMN'
'PARAMS.CMN1
'VARS.CMN'
C
C
DEFINE LOCAL VARIABLES
REAL QS(4), TS,
INTEGER IS, JYR,
DATA NO/0/
VS
JMO,
JDY,
JHR,
NO
C
C
DO 100 I - l.KEMIS
READ(INEMIS, *)JYR,JMO,JDY,JHR,IS,TS,VS,(QS(J),J-1,IPOL)
CHECK TIME AND SOURCE # FOR CONSISTENCY
IF(JYR .NE. KYR .OR. JMO .NE. KMO .OR. JDY .NE. KDY
.OR. JHR .NE. KHR) THEN
IEM00360
IEM00370
IEM00380
IEM00390
IEM00400
-IEM00410
IEMOCI420
IEM00430
IEM00440
IEMOCI450
IEMOCI460
IEM00470
IEM00480
IEM00490
IEMOCI500
IEM00510
IEMOCI520
IEM00530
IEM00540
IEM00550
IEM00560
IEM00570
IEMOCI580
IEMOCI590
IEM00600
48
-------
c
c
100
c
c
510
520
WRITE(IOUT,510)
STOP
ENDIF
KMO,KDY,KYR,KHR, JMO,JDY,JYR,JHR,IS
1
2
3
1
2
CHECK SOURCE I TO SEE IF VARIABLE EMISSIONS ARE EXPECTED
IF( IVAR(IS) .EQ. NO ) THEN
WRITE(IOUT,520) IS
STOP
ENDIF
DS - SOURCE(5,IS)
SOURCE(6,IS)-TS
SOURCE(7,IS)-VS
SOURCE(8,IS)-AMAX1(QS(IPOL),0.0)
SOURCE(10,IS)-2.45154*VS*DS*DS
SOURCE(11,IS)-0.25*VS*VS*DS*DS
CONTINUE
RETURN
FORMAT(//,5X,'PROGRAM EXECUTION TERMINATED DUE TO A DATE/TIME ',
/,5X,'INCONSISTENCY IN THE VARIABLE EMISSIONS FILE.',//,5X,
'DATE/TIME EXPECTED WAS ',12,'/ ',12,'/',12,': ',12,', AND ',/,5X,
'DATE/TIME READ WAS ',12,'/',12,'/'/12,':',12,', FOR STACK ',12)
FORMAT(//,5X,'PROGRAM EXECUTION TERMINATED DUE TO AN ',/,5X,
'UNEXPECTED STACK # (',13,') READ IN THE VARIABLE EMISSIONS ',
•FILE1)
END
IEM00610
IEM00620
IEM00630
IEM00640
IEM00650
IEM00660
IEM00670
IEM00680
IEM00690
IEM00700
IEM00710
IEM00720
IEM00730
IEM00740
IEM00750
IEM00760
IEM00770
IEM00780
IEM00790
IEM00800
IEM00810
IEM00820
IEM00830
IEM00840
IEM00850
IEM00860
IEM00870
-------
SUBROUTINE INPREC
C PURPOSE: THIS ROUTINE IS RESPONSIBLE FOR READING THE RECEPTOR DATA
C
C LIMITATIONS:
C A MAXIMUM OF 'MAXREC1 RECEPTORS
C
C ARGUMENTS
C PASSED: NONE"
C RETURNED: NONE
C
C I/O:
C INPUT: UNIT=INREC
C
C LINE VARIABLE COLUMNS FORMAT DESCRIPTION
C
C 1 NAME 1-16 A16 RECEPTOR NAME
C X 21-30 F10.0 X-COORD (USER HORIZONTAL UNITS)
C Y 31-40 F10.0 Y-COORD (USER HORIZONTAL UNITS)
C Z 41-50 F10.0 HT ABOVE GROUND (USER VERTICAL
C UNITS )
C GE 51-60 F10.0 GROUND ELEVATION (USER VERTICAL
C UNITS)
C NH 61-65 15 HILL NUMBER FOR THIS RECEPTOR
C
C OUTPUT: UNIT=IOUT
C PRINTOUT OF INPUT RECEPTOR DATA
C
C CALLING ROUTINES: CTDM (MAIN)
C
C EXTERNAL ROUTINES: PAGE
C
C INTRINSIC FUNCTIONS: MOD
C
C INCLUDE FILES: PARAMS . INC
C
C COMMON BLOCKS: IO HEAD PARAMS RECEPT STACKS
C
C
INCLUDE ' PARAMS . INC '
INCLUDE 'IO.CMN1
INCLUDE ' HEAD . CMN '
INCLUDE ' PARAMS . CMN '
INCLUDE 'RECEPT. CMN'
INCLUDE ' STACKS . CMN '
C
C DEFINE LOCAL VARIABLES
REAL X, Y, Z, GE
INTEGER NH, NR, NO, YES, FLAT
CHARACTER* 16 NAME
DATA NO/0/, YES/ I/, FLAT/0/
C
NR - 0
NRFLAT - NO
ZS = SOURCE (3,1)
C LOOP ON RECEPTOR INPUT LINES, TERMINATE ON EOF
100 CONTINUE
READ(INREC, 1010, END-900) NAME, X, Y, Z ,GE,NH
NR - NR + 1
IRC00010
-IRC00020
IRC00030
IRC00040
IRC00050
IRC00060
IRC00070
IRC00080
IRC00090
IRC00100
IRC00110
IRC00120
IRC00130
IRC00140
IRC00150
IRC00160
IRC00170
IRC00180
IRC00190
IRC00200
IRC00210
IRC00220
IRC00230
IRC00240
IRC00250
IRC00260
IRC00270
IRC00280
IRC00290
IRC00300
IRC00310
IRC00320
IRC00330
IRC00340
IRC00350
IRC00360
IRC00370
IRC00380
• TDf*rinTCin
~iKt*uujyu
IRC00400
IRC00410
IRC00420
IRC00430
IRC00440
IRC00450
IRC00460
IRC00470
IRC00480
IRC00490
IRC00500
IRC00510
IRC00520
IRC00530
IRC00540
IRC00550
IRC00560
IRC00570
IRC00530
IRC00590
IRC00600
50
-------
c
c
c
c
c
c
c
c
c
c
c
900
c
c
c
c
991
C
1000
1010
6000
6010
6020
fim n
O V J \J
9910
IF(NR .GT. MAXREC) GO TO 991
RECPT ( 1 , NR) =X*HORI2
RECPT ( 2 , NR) =V*HORIZ
RECPT ( 3 , NR) =Z *VERT
USE MINIMUM OF TOWER BASE AND LOWEST STACK BASE ELEVATION
MODEL BASE ELEVATION (ZS)
IRC00610
IRC00620
IRC00630
IRC00640
IRC00650
ASIRC00660
IRC00670
IRC00630
RECPT(4,NR) IS THE ELEVATION OF THE RECEPTOR ABOVE THE MODELIRC00690
&
&
&
&
&
&
&
1
2
3
4
1
BASE ELEVATION
RECPT(4,NR)=GE*VERT - ZS
NRHILL(NR) = NH
RECEPTORS ON FLAT TERRAIN FLAG
IF(NH .EQ. FLAT) NRFLAT = YES
PRINTOUT SECTION
IF(MOD(NR,40) .EQ. 1) THEN
IF( NR .NE. 1 ) WRITE(IOUT,6030) HORIZ.VERT
FOOTNOTE AND NEW PAGE
CALL PAGE (YES)
WRITE (IOUT, 6000)
ENDIF
IF(MOD(NR,10) .EQ. 1) WRITE(IOUT, 6010)
WRITE(IOUT, 6020) NR,NAME, X, Y, Z , GE,NH
GO TO 100
END RECEPTOR INPUT LOOP
NRECPT = NR
FOOTNOTE
WRITE (IOUT, 6030) HORIZ , VERT
RETURN
ERROR SECTION
WRITE (IOUT, 99 10) MAXREC
STOP
FORMAT SECTION
FORMAT (12, 313, 15, 14)
FORMAT (A16,4X,4F10. 0,15)
FORMAT (/, 27X, ' RECEPTOR INFORMATION1,//,
REC IDENTIFICATION EAST NORTH HEIGHT ABOVE ' ,
GRD LVL1,/,
NO . COORD COORD LOCAL GRD LVL ' ,
ELEVATION HILL1,/,
(USER UNITS) (USER UNITS) ',
(USER UNITS) NUMBER',/,
/
FORMATC ')
FORMAT(I4,2X,A16,1X,F9.2,F9.2,5X,F7.1,5X,F7.1,7X,I2)
1 MULTIPLY HORIZONTAL USER UNITS BY: ' , 1PE10 . 3 , ' TO CONVERT '
'TO METERS',/,
1 MULTIPLY VERTICAL USER UNITS BY: ' , 1PE10. 3 , ' TO CONVERT ',
'TO METERS')
FORMAT (//' ***** RECEPTOR INPUT ERROR *****'/' MAXIMUM ',
1 NUMBER OF RECEPTORS EXCEEDED: MAXREC=',I4)
END
IRC00700
IRC00710
IRC00720
IRC00730
IRC00740
IRC00750
IRC00760
IRC00770
IRC00780
IRC00790
IRC00800
IRC00810
IRC00820
IRC00830
IRC00840
IRC00850
IRC00860
IRC00870
IRC00880
IRC00890
IRC00900
IRC00910
IRC00920
IRC00930
IRC0094-6-
IRC00950
IRC00960
IRC00970
IRC00980
IRC00990
IRC01000
IRC01010
IRC01020
IRC01030
IRC01040
IRC01050
TOf^rt "I rt£ rt
iK^-U J.Uo U
IRC01070
IRC01080
IRC01090
T"D/^rt 1 T f\ n
XKwUXXU U
, IRC01110
IRC01120
IRC01130
IRC01140
IRC01150
IRC01160
IRC01170
51
-------
SUBROUTINE INPSOR ISR00010
C ISR00020
C PURPOSE: THIS ROUTINE IS RESPONSIBLE FOR READING THE SOURCE PARAMETERSISR00030
(NOTE:. EMISSIONS VARYING HOURLY ARE READ BY THE SUBROUTINE
INPEMS. THIS ROUTINE READS THE NONVARYING PARAMETERS FOR
EACH SOURCE SUCH AS LOCATION, STACK HEIGHT, ETC.
STACK BASES AND HEIGHTS ARE ADJUSTED TO A COMMON BASE
ELEVATION, (EITHER THE LOWEST STACK BASE OR THE MET
TOWER BASE). THIS THEN BECOMES THE MODEL BASE HEIGHT.
SET VARIABLE EMISSIONS >FLAG IEMIS HERE
'MAXSOR1 SOURCES (SEE PARAMS.INC)
C
C
C
C
C ASSUMPTIONS:
C
C
C
C
C
C
C
C
C
C
C
C LINE VARIABLE COLUMNS FORMAT
C 1 NAME 1-16 A16
C X 17-23 F7.0
C Y 24-30 F7.0
C Z 31-37 F7.0
C HS 38-44 F7.0
C DS 45-51 F7.0
C TS 51-58 F7.0
C VS 59-65 F7.0
C Q 66-72 F7.0
C IQ 80 II
C
C
C LAST NAME 1-4 A4
C
C
C
C
C
C
C CALLING ROUTINES: CTDM (MAIM)
C
C EXTERNAL ROUTINES: PAGE
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: 10 HEAD PARAMS STACKS
C
C INTRINSIC FUNCTIONS: MOD
C
LIMITATIONS:
A MAXIMUM OF
ARGUMENTS: NONE
I/O:
INPUT: UNIT-IN
LINE VARIABLE
1 NAME
X
Y
Z
HS
DS
TS
VS
Q
IQ
REPEAT LINE 1 FOR EACH SOURCE
OUTPUT: UNIT-IOUT
DESCRIPTION
SOURCE NAME
X-COORD (USER HORIZONTAL UNITS)
Y-COORD (USER HORIZONTAL UNITS)
BASE ELEV (USER VERTICAL UNITS)
STACK HEIGHT (M)
STACK DIAMETER (M)
STACK GAS TEMPERATURE (DEG K)
STACK GAS EXIT VELOCITY (M/S)
EMISSION RATE (G/S)
FLAG FOR VARIABLE EMISSION RATE
IQ-0 CONSTANT RATE, -1 VARIABLEISR00310
ISR00320
CHARACTERS 'ENDS' INDICATING ENDISR00330
OF SOURCE INPUT ISR0034Q_
ISR00350
ISR00360
ISR00370
ISR00040
ISR00050
ISR00060
ISR00070
ISR00080
ISRCI0090
ISR00100
ISR00110
ISR00120
ISR00130
ISR00140
ISR00150
ISR00160
ISR00170
ISR00180
ISR00190
ISR00200
ISR00210
ISR00220
ISR00230
ISR00240
ISR00250
ISR00260
ISR00270
ISR00280
ISR00290
ISR00300
PRINTOUT OF INPUT SOURCE PARAMETERS
INCLUDE
INCLUDE
INCLUDE
INCLUDE
INCLUDE
INCLUDE
'PARAMS.INC'
'IO.CMM'
'HEAD.CMN1
'PARAMS.CMN'
' STACKS.CMN'
'TOWER.CMN1
C
C
DEFINE LOCAL VARIABLES
REAL X, Y,
Z,
HS,
DS,
TS,
ISR00380
ISR00390
ISR00400
ISR00410
ISR00420
ISR00430
ISR00440
ISR00450
ISR00460
ISR00470
ISR00480
ISR00490
•ISR00500
ISR00510
ISR00520
ISR00530
ISR00540
ISR00550
ISR00560
ISROCI570
ISR00580
ISR00590
ISR00600
52
-------
20
30
40
50
60
70
C
vs,
INTEGER IQ,
CHARACTER*!
CHARACTER*4
CHARACTER*16
DATA YES/
DATA
DATA
Q, ZLOW
YES, NO
ADJUST(MAXSOR), STAR
ENDS
NAME, SNAME(MAXSOR)
V,
ENDS/ 'ENDS'
Z.LOW/1.E20/
NO/0/
ADJUST/ MAXSOR*1
STAR/ '*'/
TS, VS, Q, IQ
0.0) GO TO 30
6020) NSTACK,
0.0) GO TO 40
6030) NSTACK,
0) GO TO 70
0.0) GO TO 50
6040) NSTACK,
0.0) GO TO 60
6050) NSTACK,
CALL PAGE(YES)
IEMIS-NO "
KEMIS-0
NSTACK-0
WRITE(IOUT, 6000)
C LOOP ON SOURCE INPUT LINES
10 READ(IN,1000) NAME, X, Y, Z, HS, DS,
IF( NAME(1:4) .EQ. ENDS ) GO TO 100
NSTACK-NSTACK+1
IF(NSTACK .LE. MAXSOR) GO TO 20
WRITE(IOUT, 6010) MAXSOR, NSTACK
STOP
IF(HS. GT.
WRITEflOUT, 6020) NSTACK, HS
STOP
IF(DS .GT.
WRITE(IOUT, 6030) NSTACK, DS
STOP
IF(IQ .GT.
IF(TS .GT.
WRITE(IOUT, 6040) NSTACK, TS
STOP
IF(VS .GT.
WRITE(IOUT, 6050) NSTACK, VS
STOP
IF(Q .GT. 0.0) GO TO 80
WRITE(IOUT, 6060) NSTACK, Q
STOP
IQ-1
SET VARIABLE EMISSIONS FLAG
IEMIS-YES
C COUNTER
KEMIS-KEMIS+1
TS-0.0
VS-0.0
Q-0.0
80 SOURCE(1,NSTACK)-X*HORIZ
SOURCE(2,NSTACK)-Y*HORIZ
SOURCE(3,NSTACK)-Z*VERT
C LOOK FOR LOWEST BASE ELEVATION
IF( SOURCE(3,NSTACK) .LT. ZLOW ) ZLOW - SOURCE(3,NSTACK)
SOURCE(4,NSTACK)-HS
SOURCE(5,NSTACK)-DS
SOURCE(6,NSTACK)-TS
SOURCE(7,NSTACK)-VS
SOURCE(8,NSTACK)-Q
C RESERVED SPACE IN SOURCE ARRAY
C****** SOURCE(9,NSTACK)-BLDHT
C 2.45154-GRAVITY/4
SOURCE(10,NSTACK)-2.45154*VS*DS*DS
SOURCE(11,NSTACK)-0.25*VS*VS*DS*DS
ISR00610
ISR00620
ISR00630
ISR00640
ISR00650
ISR00660
ISR00670
ISR00680
ISR00690
ISR00700
ISR00710
ISR00720
ISR00730
ISR00740
ISR00750
ISR00760
ISR00770
ISR00780
ISR00790
ISR00800
ISR00810
ISR00820
ISR00830
ISR00840
ISR00850
ISR00860
ISR00870
ISR00880
ISR00890
ISR00900
ISR00910
ISR00920
ISR00930
ISR00948-
ISR00950
ISR00960
ISR00970
ISR00980
ISR00990
ISR01000
ISR01010
ISR01020
ISR01030
ISR01040
ISR01050
ISR01060
ISR01070
ISR01080
ISR01090
ISR01100
ISR01110
ISR01120
ISR01130
ISR01140
ISR01150
ISR01160
ISR01170
ISR01180
ISR01190
ISR01200
53
-------
c
100
c
c
c
c
c
$
$
$
$
110
c
c
1000
6000
1
2
3
4
5
6010
1
6020
1
6030
1
6040
1
6050
1
6060
1
6070
6080
SNAME( NSTACK) = NAME
IVAR (NSTACK) =IQ
GO TO 10
END INPUT LOOP
CONTINUE
CHECK IF MET TOWER BASE IS BELOW LOWEST STACK BASE
IF(ZT .LT. ZLOW) ZLOW - ZT
SET BASE HEIGHT FOR PROFILE HEIGHT ADJUSTMENT
BASEHT -~ZT - ZLOW
ADJUST STACK BASE ELEVATION AND HEIGHT AND PRINT INPUTS
DO 110 NS~-1, NSTACK
IF( MOD(NS,5) .EQ. 1) WRITE(IOUT, 6090)
IF( NS .EQ. 46 ) THEN
PRINT FOOTNOTE, NEW PAGE
WRITE(IOUT,6100) ZLOW, HORIZ, VERT
CALL PAGE (YES)
ENDIF
IF( SOURCE(3,NS) .GT. ZLOW ) THEN
STACK BASE ELEVATION IS ABOVE COMMON BASE ELEVATION
ADJUST (NS) - STAR
SOURCE(4,NS) - SOURCE(4,NS) + (SOURCE (3 ,NS) -ZLOW)
SOURCE ( 3, NS) - ZLOW
ENDIF
IF(IVAR(NS) .EQ. NO) THEN
WRITE(IOUT, 6070) NST,SNAME(NS) , SOURCE (8 ,NS).,
SOURCE(1,NS) ,SOURCE(2,NS) ,
SOURCE ( 4, NS), ADJUST (NS), ( SOURCE ( I , NS ) ,1-5,7)
ELSE
WRITE(IOUT, 6080) NS,SNAME(NS) , SOURCE (1,NS) ,
SOURCE (2 ,NS) ,SOURCE(4,NS) ,
ADJUST (NS ) , SOURCE ( 5 , NS )
ENDIF
CONTINUE
PRINT FOOTNOTE
WRITE (IOUT, 6100) ZLOW, HORIZ, VERT
RETURN
FORMAT (A16,8F7.0,7X, 11)
FORMAT (
//' ',T17,'* **SOURCE INFORMATION** *',///,
T22,' EMISSION LOCATION STK STK GAS EXIT1,/,
1 STK NAME RATE X Y ' ,
' HT DIA TEMP VEL ',/,' #' ,T23, ' (G/S) (M) (M1 ,
') (M) (M) (K) (M/S)',
FORMAT(//' *****SOURCE INPUT ERROR*****1/
' MAXIMUM NUMBER OF SOURCES EXCEEDED: MAXSOR-' , 13 ,' NSTACK- ',13)
FORMAT (//' *****SOORCE INPUT ERROR*****'/
' STACK HEIGHT LE 0.0: STACK NO-1, 13,' HS-',F6.2)
FORMAT(//' *****SOURCE INPUT ERROR*****'/
' STACK DIAMETER LE 0.0: STACK NO-', 13,' DS-',F6.2)
FORMAT(//' *****SOURCE INPUT ERROR*****'/
' STACK TEMPERATURE LE 0.0: STACK NO-', 13," DS-',F6.1)
FORMAT (//' *****SOURCE INPUT ERROR*****'/
' EXIT VELOCITY LE 0.0: STACK NO-', 13,' DS-',F6.2)
FORMAT(//' *****SOURCE INPUT ERROR*****'/
1 EMISSION RATE LE 0.0: STACK NO-',I3,' Q-',F6.2)
FORMAT(I3,1X,A16,F9.2,F9.2,1X,F9.2,1X,F6.1,A1,F6.2,F6.1,F6.2)
FORMAT (13, IX, A16, ' VAR. ' ,F9.2,F9.3, IX, F6. 1, Al,
ISR01210
ISR01220
ISR01230
ISR01240
ISR01250
ISR01260
ISR01270
ISR01280
ISR01290
ISR01300
ISR01310
ISR01320
ISR01330
ISR01340
ISR01350
ISRCI1360
ISR01370
ISR01380
ISR01390
ISR01400
ISR01410
ISR01420
ISR01430
ISR01440
ISR01450
ISR01460
ISR01470
ISR01480
ISR01490
ISR01500
ISR01510
ISR01520
ISR01530
ISR01540-
ISR01550
ISR01560
ISR01570
ISR01580
ISR01590
ISR01600
ISR01610
ISR01620
ISR01630
ISR01640
T^BOI fififl
Xd&lU AOO VJ
ISR01670
ISR01680
ISR01690
ISR01700
ISR01710
ISR01720
ISR01730
ISR01740
ISR01750
ISR01760
ISR01770
ISR01780
ISR01790
ISR01800
54
-------
1 F6.2,1 VAR. VAR. '} ISR01810
6090 FORMAT(' ') ISR01820
6100 FORMAT(/, ' ',//, ISR01830
COMMON BASE ELEVATION - ',F7.1,' (METERS).1,/, ISR01840
THIS BASE ELEVATION IS USED FOR ALL STACKS IN THIS RUN;1,/, ISR01850
1
2
3
4
5
6
7
8
ALL STACK HEIGHTS MARKED WITH * HAVE BEEN ADJUSTED TO ',/,ISR01860
END
RETAIN THE ACTUAL ELEVATION OF THE TOP OF THE STACKS.'///
MULTIPLY HORIZONTAL USER UNITS BY:',1PE10.3,' TO CONVERT '
rTO METERS',/,
MULTIPLY VERTICAL USER UNITS BY:',1PE10.3,' TO CONVERT ',
'TO METERS')
ISR01870
ISR01880
ISR01890
ISR01900
ISR01910
ISR01920
55
-------
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
SUBROUTINE INFTEK
PURPOSE: THIS ROUTINE IS RESPONSIBLE FOR READING THE TERRAIN
INFORMATION FOR EACH HILL.
ASSUMPTIONS: THIS FIRST CONTOUR HEIGHT IS LESS THAN OR EQUAL TO THE
LOWEST STACK BASE ELEVATION
LIMITATIONS :
A MAXIMUM OF 'MAXHIL' HILLS
A MAXIMUM OF 'MAXZ1 INTERMEDIATE HEIGHTS FOR WHICH CONTOUR
AND HILL SHAPE INFORMATION IS GIVEN
ARGUMENTS: NONE
I/O:
INPUT: UNIT-INTERR, IN
THE FOLLOWING INDICATE THE GROUP OF INPUT LINES EXPECTED
FOR EACH HILL.
LINE VARIABLE COLUMNS FORMAT DESCRIPTION
1 NH 6- 7 12 HILL NUMBER
FOR THIS RECEPTOR GROUP
NZ 9-10 12 NUMBER OF HEIGHTS FOR WHICH
CONTOUR AND CUTOFF HILL SHAPE
INFORMATION IS GIVEN
HTP 21-30 F10.0 HEIGHT OF TOP OF HILL
ABOVE GRID ZERO, USER UNITS
HILNAM 41-80 A40 DESCRIPTION FOR THIS HILL
NEXT NZH LINES, ONE FOR EACH BEST-FIT ELLIPSE
ZH 1-10 F10.0 ELEVATION OF BEST-FIT ELLIPSE,
USER COORDINATES
XHW 11-20 F10.0 X-COORD (USER HORIZONTAL UNITS)
OF ELLIPSE CENTER
YHW 21-30 F10.0 Y-COORD (USER HORIZONTAL UNITS)
OF ELLIPSE CENTER
MAJORW 31-40 F10.0 ORIENTATION OF MAJOR AXIS OF
ELLIPSE (DEGREES CLOCKWISE FROM
NORTH)
MAJAXW 41-50 F10.0 LENGTH OF MAJOR SEMIAXIS, USER
COORDINATES
MINAXW 51-60 F10.0 LENGTH OF MINOR SEMIAXIS, USER
COORDINATES
NEXT NZH LINES, ONE FOR EACH CUT-OFF HILL
ZH 1-10 F10.0 ELEVATION OF BASE OF CUT-OFF
HILL, USER COORDINATES
XHL 11-20 F10.0 X-COORD (USER HORIZONTAL UNITS)
OF CENTER OF CUT-OFF HILL
YHL 21-30 F10.0 Y-COORD (USER HORIZONTAL UNITS)
OF CENTER OF CUT-OFF HILL.
MAJORL 31-40 F10.0 ORIENTATION OF MAJOR AXIS OF
CUT-OFF HILL (DEGREES CLOCKWISE
FROM NORTH)
EXPOMA 41-50 F10.0 EXPONENT IN INVERSE POLYNOMIAL
FUNCTION FOR CUT-OFF HILL SHAPE
ITR00010
-ITR00020
ITR00030
ITR00040
ITR00050
ITR00060
ITR00070
ITR00080
ITR00090
ITR00100
ITR00110
ITR00120
ITR00130
ITR00140
ITR00150
ITR00160
ITR00170
ITR00180
ITR00190
ITR00200
ITR00210
ITR00220
ITR00230
ITR00240
ITR00250
ITR00260
ITR00270
ITR00280
ITR00290
ITR00300
ITR00310
ITR00320
ITR00330
ITR0034fl_
ITR00350
ITR00360
ITR00370
ITR00380
ITR00390
ITR00400
ITR00410
ITR00420
ITR00430
ITR00440
ITR00450
ITR00460
ITR00470
ITR00480
ITR00490
ITR00500
ITR00510
ITR00520
ITR00530
ITR00540
ITR00550
ITR00560
ITROCI570
ITR00580
ITR00590
ITR00600
56
-------
c
C EXPOMI 51-60 F10.
C
C
C SCALMA 61-70 F10.
C
C
C
C SCALMI 71-80 F10.
C
C
C
C
C
FOR MAJOR AXIS CROSS SECTION
0 EXPONENT IN INVERSE POLYNOMIAL
FUNCTION FOR CUT-OFF HILL SHAPE
FOR MINOR AXIS CROSS SECTION
0 SCALE LENGTH IN INVERSE
POLYNOMIAL FUNCTION FOR CUT-OFF
HILL SHAPE FOR MAJOR AXIS CROSS
SECTION
0 SCALE LENGTH IN INVERSE
POLYNOMIAL FUNCTION FOR CUT-OFF
HILL SHAPE FOR MINOR AXIS CROSS
SECTION
C THIS GROUP OF INPUT LINES SHOULD BE REPEATED FOR EACH HILL.
C AFTER THE LAST HILL, AN END-OF-FIL WILL OCCUR FOR I/O UNIT
C INTERR. THEN, AN ADDITIONAL
C
C ZOH FREE FORMAT
C
C
C OUTPUT: UNIT-IOUT
LINE WILL BE READ FROM I/O UNIT IN:
ROUGHNESS LENGTH (M)
ONE FOR EACH HILL
C PRINTOUT OF INPUT TERRAIN DATA
C
C CALLING ROUTINES: CTDM (MAIN)
C
C EXTERNAL ROUTINES: LINES PAGE
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST IO HILL PARAMS STACKS
C
C
INCLUDE 'PARAMS.INC1
INCLUDE ' CONST . CMN •
INCLUDE 'HILL. CMN'
INCLUDE '10. CMN1
INCLUDE 'PARAMS. CMN'
INCLUDE ' STACKS . CMN '
C
C DEFINE LOCAL VARIABLES
REAL ZH(MAXZ), ZS
INTEGER NEWPGE, NH, NZ, I, 11
C
DATA YES/ I/
C
NHILLS - 0
ZS - SOURCE (3,1)
C
CALL PAGE (YES)
WRITE (IOUT, 6010)
CALL LINES (2, NO, NEWPGE)
C
100 READ( INTERR, 1010, ERR-9000,
, 12, NG, NCR, NL, YES
END-500) NH, NZ, HTP,
$ (HILNAM ( I, NHILLS+1) ,1-1,10)
1010 FORMAT(5X,I2,1X,I2,10X,F10.0,
NHILLS - NHILLS + 1
C CHECK FOR OUT OF SEQUENCE
IF( NH .NE. NHILLS ) THEN
10X,10A4)
ITR00610
ITR00620
ITR00630
ITR00640
ITR00650
ITR00660
ITR00670
ITR00680
ITR00690
ITR00700
ITR00710
ITR00720
ITR00730
ITR00740
ITR00750
ITR00760
ITR00770
ITR00780
ITR00790
ITR00800
ITR00810
ITR00820
ITR00830
ITR00840
ITR00850
ITR00860
ITR00870
ITR00880
ITR00890
ITR00900
ITR00910
ITR00920
. TTO ArtO "1 rt
'X.TKOO930
ITR0094&-
ITR00950
ITR00960
ITR00970
ITR00980
ITR00990
ITR01000
ITR01010
ITR01020
ITR01030
ITR01040
ITR01050
ITR01060
ITR01070
ITR01080
ITR01090
ITR01100
ITR01110
ITR01120
ITR01130
ITR01140
ITR01150
ITR01160
ITR01170
ITR01180
ITR01190
ITR01200
57
-------
1120
C
c
WRITE( TOUT, 1110) NHILLS, NH
1110 FORMAT(//,10X,'HILL NUMBER OF OUT SEQUENCE—',12,' WAS ',
1 'EXPECTED; ',12,' WAS READ')
STOP
ENDIF
C CHECK FOR ARRAY OUT OF BOUNDS
IF( NZ .GT. MAXZ ) THEN
WRITE,(IOUT,1120) NZ,MAXZ
FORMAT(//,10X,'NUMBER OF CONTOURS/CUT-OFF HILLS =• ',12,
'; EXCEEDS MAXIMUM ALLOWABLE (21)')
STOP "
ENDIF
CHECK IF HEADER PLUS WRAP HILL ELLIPSE INFO FITS ON PAGE
NL - 6 + NZ
CALL LINES(NL,YES,NEWPGE)
IF( NEWPGE .EQ. YES ) THEN
FOOTNOTE, NEW PAGE
WRITE( IOUT, 6100) HORIZ, VERT
WRITE( IOUT, 6011)
CALL LINES(2,NO,NEWPGE)
ENDIF
WRITE( IOUT, 6020 ) NH, (HILNAM(I,NH),1-1,10), HTP
WRITE( IOUT, 6030 ) (HILNAM(I,NH),1-1,10)
READ VARIABLES FOR WRAP: ELLIPSE INFORMATION
DO 200 I - 1,NZ
READ(INTERR,1040,ERR-9000) ZH(I),XHW(I,NH),YHW(I,NH),
MAJORW(I,NH),MAJAXW(I,NH),MINAXW(I,NH)
FORMAT(6F10.0)
WRITE(IOUT,6040) ZH(I),XHW(I,NH),YHW(I,NH),MAJORW(I,NH),
MAJAXW(I,NH),MINAXW(I,NH)
CONTINUE
READ VARIABLES FOR LIFT: CUT-OFF HILL INFORMATION
NL - 5 + NZ
CALL LINES(NL,YES,NEWPGE)
IF( NEWPGE .EQ. YES ) THEN
C FOOTNOTE, NEW PAGE
WRITE( IOUT, 6100) HORIZ, VERT
WRITE(IOUT,6011)
CALL LINES(2,NO,NEWPGE)
ENDIF
WRITE(IOUT,6050) (HILNAM(I,NH),1-1,10)
DO 300 I - 1,NZ
READ(INTERR,1050,ERR-9000) EL,XHL(I,NH),YHL(I,NH),MAJORL(I,
1 NH),EXPOMA(I,NH),EXPOMI(I,NH),SCALMA(I,NH),SCALMI(I,NH)
1050 FORMAT(8F10.0)
IF(ABS(EL-ZH(I)).GT.SMALL) THEN
WRITE(IOUT,1140) I,EL,I,ZH(I)
1140 FORMAT(//,10X,'CUT-OFF HILL BASE I ',12,' - ',F7.2,
* '; DOES NOT AGREE WITH THE CORRESPONDING ',
* 'CONTOUR # ',12,' HEIGHT OF «,F7.2)
STOP
ENDIF
WRITE(IOUT,6060) EL,XHL(I,NH),YHL(I,NH),MAJORL(I,NH),
* EXPOMA(I.NH),EXPOMI(I,NH),
* SCALMA(I,NH),SCALMI(I,NH)
C
C
C
1040
200
C
C
c
ITR01210
ITR01220
ITR01230
ITR01240
ITR01250
ITR01260
ITR01270
ITR01280
ITR01290
ITRCI1300
ITR01310
ITR01320
ITR01330
ITR01340
ITR01350
ITR01360
ITR01370
ITR01380
ITR01390
ITR01400
ITR01410
ITR01420
ITR01430
ITR01440
ITR01450
ITR01460
ITR01470
ITR01480
ITR01490
ITR01500
ITR01510
ITR01520
ITR01530
ITR01546-
ITR01550
ITR01560
ITR01570
ITR01580
ITR01590
ITR01600
ITR01610
ITR01620
ITR01630
ITR01640
ITR01650
ITR01660
ITR01670
ITR01680
ITR01690
ITR01700
ITR01710
ITR01720
ITR01730
ITR01740
ITR01750
ITR01760
ITR01770
ITR01780
ITR01790
ITR01800
58
-------
300
C
C
C
400
C
C
500
600
C
C
C
9000
9005
9010
9015
9999
C
6010
6011
6020
6030
CONTINUE
CONVERT TO METERS USING HORIZ AND VERT
NZH(NH) - NZ
THS(NH) - HTP * VERT - ZS
DO 400 I - 1,NZ
ZHS(I,NH) - ZH(I) * VERT - ZS
XHW(r,NH) - XHW(I,NH) * HORIZ
YHW(I,NH) - YHW(I,NH) * HORIZ
XHL(T,NH) - XHL(I,NH) * HORIZ
YHL(I,NH) - YHL(I,NH) * HORIZ
MAJAXW(I,NH) - MAJAXW(I,NH) * HORIZ
MINAXW(I,NH) - MINAXW(I,NH) * HORIZ
SCALMA(I,NH) - SCALMA(I,NH) * HORIZ
SCALMI(I,NH) - SCALMI(I,NH) * HORIZ
CONTINUE
CHECK IF FIRST CONTOUR LE LOWEST STACK BASE ELEVATION
IF( ZHS(1,NH) .GT. 0.0) GO TO 9010
READ NEXT HILL INFO
GO TO 100
END OF TERRAIN INPUT
CONTINUE
WRITE(IOUT,6100) HORIZ, VERT
READ HILL ROUGHNESS LENGTHS
READ(IN,*) (ZOH(NH),NH-1,NHILLS)
NGR - (NHILLS-l)/8 + 1
NL - NGR * 3 + 6
CALL LINES (NL, YES, NEWPGE)
WRITE(IOUT,6070)
DO 600 NG-1,NGR
I2-NG*8
IF (12 .GT. NHILLS) I2-NHILLS
WRITE (IOUT, 6080) (1,1-11,12)
WRITE (IOUT, 6090) (ZOH(I) , I-I1, 12)
CONTINUE
RETURN
TERMINAL ERROR .
WRITE (IOUT, 9005)
FORMAT (//,10X, 'ERROR IN DATA READ IN HILL INPUT')
GO TO 9999
WRITE (IOUT, 90 15) NH
FORMAT (//,' FIRST CONTOUR OF HILL ',13,' IS ABOVE COMMON ',
'STACK BASE ',//,' PROGRAM TERMINATING ' ,//)
GO TO 9999
STOP
FORMAT (' TERRAIN INFORMATION (USER UNITS FOR ALL DATA)')
FORMAT (' TERRAIN INFORMATION (CONT.)1)
FORMAT(/« HILL*', 12,' ' ,10A4, 'HILL TOP: ' ,F7. 1,
' (USES UNITS) ')
FORMAT(/' BEST FIT ELLIPSE INFORMATION FOR WRAP: ',10A4,/
1 CONTOUR X-COORD Y-COORD MAJOR AXIS ELLIPSE AXIS
•LENGTHS',/,
' HEIGHT (HILL CENTER) AZIM. FROM N MAJOR
'MINOR1,/,
i —————— —_——_——— ——____— ———_——_————_ _————_—— i
ITR01810
ITR01820
ITR01830
ITR01840
ITR01850
ITR01860
ITR01870
ITR01880
ITR01890
ITR01900
ITR01910
ITR01920
ITR01930
ITR01940
ITR01950
ITR01960
ITR01970
ITR01980
ITR01990
ITR02000
ITR02010
ITR02020
ITR02030
ITR02040
ITR02050
ITR02060
ITR02070
ITR02080
ITR02090
ITR02100
ITR02110
ITR02120
ITR02130
ITR02140_
ITR02150
ITR02160
ITR02170
ITR02180
ITR02190
ITR02200
ITR02210
ITR02220
ITR02230
ITR02240
ITR02250
ITR02260
ITR02270
ITR02280
ITR02290
ITR02300
ITR02310
ITR02320
ITR02330
ITR02340
ITR02350
ITR02360
ITR02370
ITR02380
ITR02390
ITR02400
59
-------
6040
6050
6060
6070
6080
6090
m t\f\
*
1
2
3
4
;
FORMAT(F9.1,2F10.3,F11.1,2X,2F11.3)
FORMAT(/' He CUT-OFF HILL INFORMATION FOR LIFT: ',10A4,/,
CONTOUR X-COORD Y-COORD MAJOR AXIS < INVERSE ' ,
POLYNOMIAL VARIABLES > ' , / ,
HEIGHT (HILL CENTER) AZIM. FROM N MAJ EXP MIN EXP ' ,
MAJ SCALE MIN SCALE ' , / ,
/
FORMAT ( F9 . 1 , F10 . 3 , F9 . 3 , F10 . 1 , Fll . 3 , F8 . 3 , F12 . 3 , Fll . 3 )
FORMAT (/-
1 SURFACE ROUGHNESS LENGTH OF EACH HILL:',/)
FORMAT (' HILL # ',818)
FORMATC ZO (M) ',8F8.3,/)
' MULTIPLY HORIZONTAL USER UNITS BY: ' , 1PE10. 3 , ' TO CONVERT ',
•TO METERS',/,
1 MULTIPLY VERTICAL USER UNITS BY: ' , 1PE10. 3 , ' TO CONVERT ',
'TO METERS')
END
ITR02410
ITR02420
ITR02430
ITR02440
ITR02450
ITR02460
ITR02470
llKU24oU
irKQ24yu
ITR02500
ITR02510
ITR02530
ITR02540
ITR02550
TTTJrtO e^fi
ITR02570
ITR02580
ITR02590
ITR02600
ITR02610
60
-------
SUBROUTINE INPTOW
C PURPOSE: THIS ROUTINE IS RESPONSIBLE FOR READING THE MET TOWER
C POSITION INFORMATION. THE HEIGHTS READ FROM THE PROFILE DATA
ITW00010
_ T^Mrt f\ f\ r\ f\
i. 1 WUUU2 U
ITW00030
ITW00040
C FILE ARE REFERENCED TO THE TOWER BASE HEIGHT AND ARE ADJUSTEDITW00050
C HEIGHT CANNOT BE NEGATIVE.
C
C LIMITATIONS:
c ONLY ONE 'TOWER POSITION is CONSIDERED.
c
C ARGUMENTS
C PASSED: NONE
C RETURNED: NONE
C
C I/O:
C INPUT: UNIT-IN (CTDM.IN, LINE 4)
C
C THE FOLLOWING INDICATE THE GROUP OF INPUT LINES EXPECTED
C FOR EACH HILL.
C
C LINE VARIABLE COLUMNS FORMAT DESCRIPTION
C 1 LABEL 1-20 A20 LABEL FOR THIS TOWER
C FOR THIS RECEPTOR GROUP
C XT 21-30 F10.0 X COORDINATE OF TOWER, USER
C UNITS
C YT 31-40 F10.0 Y COORDINATE OF TOWER, USER
C UNITS
C ZT 41-50 F10.0 HEIGHT OF TOWER BASE, USER
C UNITS
C
C OUTPUT: UNIT-IOUT
C PRINTOUT OF INPUT TOWER DATA
C
C CALLING ROUTINES: CTDM (MAIN)
C
C EXTERNAL ROUTINES: LINES
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS:
C 10 PARAMS TOWER
C
C
c
INCLUDE 'PARAMS.INC'
INCLUDE 'IO.CMN'
INCLUDE 'P ARAMS. CMN'
INCLUDE 'TOWER. CMN'
C
C DEFINE LOCAL VARIABLES
REAL XTIN, YTIN, ZTIN
INTEGER YES, NEWPGE
CHARACTER* 20 LABEL
DATA YES/ I/
C
READ(IN, 5010, ERR-9000) LABEL, XTIN, YTIN, ZTIN
CALL LINES (4, YES, NEWPGE)
C
C CONVERT TO MODEL COORDINATE SYSTEM
ITW00060
ITW00070
ITW00080
ITW00090
ITW00100
ITW00110
ITW00120
ITW00130
ITW00140
ITW00150
ITW00160
ITW00170
ITW00180
ITW00190
ITW00200
ITW00210
ITW00220
ITW00230
ITW00240
ITW00250
ITW00260
ITW00270
ITW00280
ITW00290
ITW00300
ITW00310
ITW00320
ITW00330
ITW00340-
ITW00350
ITW00360
ITW00370
ITW00380
ITW00390
ITW00400
ITW00410
ITW00420
ITW00430
TTIUrtrt A A f\
•ITWOO44O
ITW00450
ITW00460
ITW00470
ITW00480
ITW00490
ITW00500
ITW00510
ITW00520
ITW00530
ITW00540
ITW00550
ITW00560
ITW00570
ITW00580
ITW00590
ITW00600
SI
61
-------
C ITW00610
XT - XTIN * HORIZ ITW00620
YT = YTIN * HORIZ ITW00630
ZT - ZTIN * VERT ITW00640
WRITE(IOUT, 6010) XTIN,HORIZ,XT,YTIN,HORIZ,YT,ZTIN,VERT,ZT ITWQ0650
RETURN ITW00660
9000 WRITE(IOUT, 6900) ITW00670
STOP _ ITW00680
5010 FORMAT(A20,3F10.0) ITW00690
6010 FORMAT(/, ITW00700
& METEOROLOGICAL TOWER COORDINATE INFORMATION:',/,5X, ITW00710
& X-COORD: ',F9.3,' (USER UNITS) * ',F8.4,' - ',F7.1, ITW00720
& (METERS)',/,5X, ITW00730
& Y-COORD: ',FC.3,' (USER UNITS) * ',F8.4,' = ',F7.1, ITW00740
& (METERS)',/,5X, ITW00750
& ELEVATION: ',F9.3,' (USER UNITS) * ',F8.4,' - ',F7.1, ITW00760
& METERS)') ITW00770
6900 FORMAT(//' * READ ERROR FROM INPTOW, PROGRAM TERMINATING *') ITW00780
END ITW00790
62
-------
INTEGER FUNCTION KLOSE( XA, NA, X)
C PURPOSE: THIS FUNCTION RETURNS THE POSITION OF THE DATA VALUE IN
C XA WHICH IS NEAREST TO THE VALUE X BUT LESS THAN X
C
C ASSUMPTIONS:
C ARRAY XA IS SORTED IN ASCENDING ORDER
C
C LIMITATIONS: IF XA ARE ALL > X, SET KLOSE » 0
C
C ARGUMENTS
C PASSED:
C XA REAL ARRAY OF VALUES TO BE SEARCHED
C NA INT DIMENSION OF XA
C X REAL VALUE TO BE SEARCHED FOR
C RETURNED FUNCTION VALUE:
C KLOSE INT ARRAY SUBSCRIPT OF NEAREST VALUE TO X
C
C I/O: NONE
C
C CALLING ROUTINES: GETDTH GETSV GETSW GETTA GETWD GETWS
C GETUV HCRIT SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: ABS
C
C COMMON BLOCKS: NONE
C
C
C DEFINE ARGUMENTS
INTEGER NA
REAL XA(NA), X
C
C IF NO XA VALUES ARE LESS THAN X, SET KLOSE - 0
C
IF( XA(1) .GT. X ) THEN
KLOSE - 0
ELSE IF( XA(1) .EQ. X } THEN
KLOSE - 1
ELSE
DO 10 KLOSE - NA, 1, -1
IF( XA(KLOSE) .LT. X ) RETURN
10 CONTINUE
ENDIF
RETURN
END
KLS00010
ARRAYKLS00030
KLS00040
KLS00050
KLS00060
KLS00070
KLS00080
KLS00090
KLS00100
KLS00110
KLS00120
KLS00130
KL500140
KLS00150
KLS00160
KLS00170
KLS00180
KLS00190
KLS00200
KLS00210
KLS00220
KLS00230
KLS00240
KLS00250
KLS00260
KLS00270
, KLS00280
KLS00290
KLS00310
KLS00320
KLS00330
KLS00349-
KLS00350
KLS00360
KLS00370
KLS00380
KLS00390
KLS00400
KLS00410
KLS00420
KLS00430
KLS00440
KLS00450
KLS00460
KLS00470
KLS00480
63
-------
SUBROUTINE LIFT(QS)
C PURPOSE: HANDLES FLOW ABOVE HC.
C
C ARGUMENTS:
C PASSED:
C QS REAL EMISSION RATE [G/S]
C RETURNED: NONE
C
C I/O: NONE
C INPUT: NONE
C OUTPUT: UNIT-IOUT CONCENTRATION (IF I CASE-YES)
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: FLAT FLOW LVDF MIX
C
C INTRINSIC FUNCTIONS: AMAX1 AMIN1 SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST 10 PARAMS PASL PASVAL VARS
C
f* Li ^
INCLUDE 'PARAMS.INC'
INCLUDE • PARAMS. CMN'
INCLUDE 'IO.CMN1
INCLUDE 'VARS. CMN1
INCLUDE 'CONST. CMN1
INCLUDE 'PASVAL. CMN1
INCLUDE 'PASL. CMN1
C
C DEFINE ARGUMENTS
REAL QS
C
C DEFINE LOCAL VARIABLES
REAL LXI
C
CO-500000. * QS/(TWOPI*US)
ZSPHC-HPL+HC
ZSMHC-HPL-HC
C CALC DISTANCE ALONG PHIM FROM SOURCE TO RECEPTOR, CALC TRAVEL TIMES
SM-XEPL-XSEPL
IF(SM .GT. SO) THEN
ZTO-SO/UV
ZTR- { SM-SO ) /UV+ZTO
YTO-SO/UV
YTR-SM/UV
C CALCULATE SIGMA-Z VALUES ....EQN. 12
SZSQ- (S1GW* ( ZTR+ZTV) ) **2/ ( 1 . 0+0 . 5 * ( ZTR+ZTV) /TTLZ )
SZOSQ- (SIGW* { ZTO+ZTV) ) **2/ ( 1 . 0+0 . 5* (ZTO+ZTV) /TTLZ )
SZPSQ-AMAX1 (0.0, SZSQ-SZOSQ)
SZFLAT - SQRT (SZSQ)
SZO-SQRT (SZOSQ)
SZP-SQRT(SZPSQ)
C CALCULATE THE SIGMA- Y VALUES ....EQN. 19
SYSQ- (SIGV* (YTR+YTV) ) **2/ (1 . 0+0 . 5* (YTR+YTV)/TTLY)
SYOSQ- (SIGV* ( YTO+YTV) ) **2/ ( 1 . 0+0 . 5* ( YTO+YTV) /TTLY)
SYPSQ-SYSQ-SYOSQ
SYFLAT - SQRT (SYSQ)
LFT00010
LFT00030
LFT00040
LFT00050
LFT00060
LFTCI0070
LFT00080
LFT00090
LFT00100
LFT00110
LFT00120
LFT00130
LFT00140
LFT00150
LFT00160
LFT00170
LFT00180
LFT00190
LFT00200
LFT00210
LFT00220
LFT00230
LFT00250
LFT00260
LFT00270
LFT00280
LFT00290
LFT00300
LFT00310
LFT00320
LFT00330
LFT0034IL
LFT00350
LFT00360
LFT00370
LFT00380
LFT00390
LFT00400
LFT00410
LFT00420
LFT00430
LFT00440
LFT00450
LFT00460
LFT00470
LFT00480
LFT00490
LFT00500
LFT00510
LFT00520
LFTOCI530
LFT00540
LFT00550
LFT00560
LFT00570
LFT00580
LFT00590
LFT00600
-------
c
c
ELSE
(SET SZP TO ZERO TO SIGNAL RECEPTOR UPWIND OF CUT-OFF HILL)
SZP-0.0
ENDIF
IF RECEPTOR IS UPWIND OF THE CUT-OFF HILL, DO A RECEPTOR-ON-A-POLE
IF(SZP .EQ. 0.) THEN
ZG - Z - ZELEV
CALL FLAT(QS,AMIN1(HC,ZG)+ZELEV)
RETURN
ENDIF
ESTIMATE THE DEPTH OF AN INNER MIXED LAYER ABOVE HC
HMIX-0.0
DELS-AMAX1((SM-SO),0.)
TEST-D£LS*HC
IF (TEST .GT. 0.) THEN
********************************************************************
UBYN-FR*HH
AVOID NEAR-NEUTRAL EST. : SET U/N TO HC IF HC BECOMES SMALLER
UBYN-AMIN1(FR*HH,HC)
CALL MIX(DELS,UBYN.HMIX)
ENDIF
C FIND THE INDEX FOR THE TY,TZ VALUES AT XEPL
SLAST-SG(MXDPTS)
C SCALE DISTANCE BY LX TO AVOID DIFFERENCING SQUARES OF LARGE NUMBERS
LXI-l./LX
SLND-SLAST*LXI
SMND-SM*LXI
IF(SM .LE. SO) THEN
K-0.
ELSEIF(SM .GT. SLAST) THEN
K-MXDPTS+1
C ULAGO IS THE LAGRANGIAN LENGTH SCALE BASED ON THE TIME SCALE TLO
C EQN. A-8
ULAGO-UV*TTLZ
TOPZ-ULAGO*
-------
C FOR POINTS DOWNWIND OF GRID, INTEGRATE DIFFUSIVITY APPROXIMATED AS LFT01210
C KZ-SIGW**2 * T / (1 + T/TL ) LFT01220
C KY-SIGV**2 * T LFT01230
TOP=ULAGO* (SM-SO+ULAGO*ALOG( (ULAGO+SO)/ LFT01240
* (ULAGO+SM))) LFT01250
TZSQ=-TOP/(BOTZ+UIAGO*(SM-SLAST+ULAGO*ALOG( (ULAGO+SLAST)/ LFT01260
* (ULAGO+SM)))) LFT01270
TOP-SMND*SMND-1. LFT01280
TYSQ-TOP/ (BOTY+SMND*SMND-SLND*SLND) LFTCI1290
ENDIF LFT01300
TZ=»SQRT(TZSQ) LFT01310
C CALCULATE THE EFFECTIVE SIGMAS EQN. 38 LFT01320
SZESQ-SZOSQ+SZPSQ/TZSQ LFT01330
SYESQ-SYOSQ+SYPSQ/TYSQ LFT01340
SZE-SQRT(SZESQ) LFT01350
SYE-SQRT(SYESQ) LFT01360
C COMPUTE EFFECTIVE RECEPTOR LOCATION RELATIVE TO THE UNDEFLECTED LFT01370
C PLUME CENTERLINE. NOTE THAT ZELEV IS THE ELEVATION OF THE RECEPTOR LFT01380
C ABOVE THE SURFACE OF THE HILL. LFT01390
CALL FLOW(XEPL,YEPL,ZELEV,ETA,DEL,DUM1,DUM2,DUM3) LFT01400
ZEFF-ZELEV+HH*HILHGT(XEPL,YEPL) -ETA LFT01410
YEFF-YEPL-DEL LFT01420
IF(HMIX .LE. ZEFF) HMIX-0. LFT01430
DY-YSEPL-YEFF LFT01440
C COMPUTE THE CONCENTRATION AS CHI/Q IN MICROSECONDS PER M**3 LFT01450
C EQN. 39 LFT01460
ARGY-0.5*DY*DY/SYESQ LFT01470
IF (ARGY .GT. 30.) THEN LFT01480
C-0.0 LFT01490
ELSE LFT01500
YFAC-EXP(-ARGY) LFT01510
AZ-TZ/(SQR2*SZO*SZP*SZE) LFT01520
DUM1-AZ*ZSMHC*SZPSQ/TZSQ LFT01530
DUM2-AZ*ZSPHC*SZPSQ/TZSQ LFT0154JL
DUM3P-AZ*SZOSQ LFT01550
DUM-0.5/SZESQ LFT01560
IF(HMIX .GT. 0.) THEN LFT01570
C WHEN MIXING LAYER IS PRESENT, MIX MATERIAL WITHIN THE LAYER... LFT01580
C (SAMPLE VERTICAL PROFILE AND THEN AVERAGE) . LFT01590
DELH-SZE*0.5 LFT01600
NLAYER-1+HMIX/DELH . LFT01610
DELH-HMIX/NLAYER LFT01620
TOTAL-0.0 LFT01630
DO 8 L-1,NLAYER+1 LFT01640
ZL-(L-1)*DELH LFT01650
CALL LVDF(ZL,DUM,DUM1,DUM2,DUM3P,ZSMHC,ZSPHC,ZF) LFT01660
IF(L .EQ. 1 .OR. L .EQ. NLAYER-H) ZF-0.5*ZF LFT01670
8 TOTAL-TOTAL+ZF LFT01680
ZFAC-TOTAL/NLAYER LFT01690
ELSE LFT01700
CALL LVDF(ZEFF,DUM,DUM1,DUM2,DUM3P,ZSMHC,ZSPHC, LFT01710
* ZFAC) LFT01720
ENDIF LFT01730
OCO*YFAC*ZFAC/(SZE*SYE) LFT01740
ENDIF LFT01750
IF(ICASE .EQ. 1) WRITE(IOUT,101) LFT01760
$ NR,SM,DY,Z,ZSMHC-ZEFF,SYFLAT,SZFLAT,SYE,SZE,C LFT01770
RETURN LFT01780
C LFT01790
101 FORMAT(/1X,I3,' L«,F8.0,3X,F8.1,2X,F7.1,2X,F7.1,1X,2F6.1,IX, LFT01800
66
-------
1 2F6.1,1X,1PE10.4) LFT01810
END LFT01820
67
-------
SUBROUTINE LIFTIN(IFLOW)
C PURPOSE: SET UP DATA NEEDED BY LIFT FOR ALL RECEPTORS
C
C ARGUMENTS:
C PASSED: NONE
C
C RETURNED:
C IFLOW INT FLAG IF 0 MODEL THIS HOUR
C IF 1 DO NOT MODEL THIS HOUR
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: ERF HILROT PATH
C
C INTRINSIC FUNCTIONS: ABS AMIN1 EXP SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST PARAMS PASL PASVAL VARS
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' CONST. CMN1
INCLUDE 'PARAMS. CMN1
INCLUDE 'PASL. CMN'
INCLUDE ' PASVAL . CMN '
INCLUDE 'VARS. CMN'
C DEFINE ARGUMENTS
INTEGER IFLOW
C
C DEFINE LOCAL VARIABLES
REAL ADD, ADDSQ, AH, B2SQ, B3SQ, BH, BOT, BOTY, BOTZ,
* DELANG, DELTAT, ERFM, ERFP, EXFADD, EXPSUB, FZK, FZO,
* HS, R2SZOI, SUB, SUBSQ, THM, TKM1YP, TKM1Z, TKM1ZP,
* TKY, TKYP, TKZ, TKZP, TLM, TO, TOP, TOPY, TOPZ, TOY,
* TOZ, TSV, TSW, TSWBYH, TTLZI, TTLZKI, TUM, XM, XO
INTEGER K
C
C ANGLE (CCW) FROM THE X-AXIS (ALONG FLOW) TO THE MINOR AXIS OF THE
C HILL IS DELANG
DELANG-PIBY2-PHIM-I-PHIHL
IF (DELANG .GT. PIBY2) DELANG-DELANG-PI
IF (DELANG .LT. -PIBY2) DELANG-DELANG-fPI
C CALCULATE THE CENTER-OF-MASS OF PLUME MATERIAL ABOVE HC (ZMASS)
R2SZOI-1./(SQR2*SZTEST)
ADD-(HPLH-HC) *R2SZOI
SUB-(HPL-HC) *R2SZOI
ERFP-ERF(ADD)
ERFM-ERF(SUB)
ADDSQ-ADD*ADD
SUBSQ-SUB*SUB
EXPADD-0.
EXPSUB-0 .
IF(ADDSQ .LT. 30.) EXP ADD-EXP(- ADDSQ)
IF (SUBSQ .LT. 30.) EXPSUB-EXP( -SUBSQ)
TOP-SZTEST/SQR2PI* (EXPADD+EXPSUB) +HPL* . 5* (ERFP+ERFM)
BOT-1 . + . 5* ( ERFM-ERFP)
LFI00010
LFI00030
LFI00040
LFI00050
LFI00060
LFI00070
LFI00080
LFI00090
LFI00100
LFI00110
LFI00120
LFI00130
LFI00140
LFI00150
LFI00160
LFI00170
LFI00180
LFI00190
LFI00200
LFI00210
LFI00220
LFI00240
LFI00250
LFI00260
LFI00270
LFI00280
LFI00290
LFI00300
LFI00310
LFI00320
LFI00330
LFI00348-
LFI00350
LFI00360
LFI00370
LFI00380
LFI00390
LFI00400
LFI00410
LFI00420
LFI00430
LFI00440
LFI00450
LFI00460
LFI00470
LFI00480
LFI00490
LFI00500 .
LFI00510
LFI00520
LFI00530
LFI00540
LFI00550
LFI00560
LFI00570
LFI00580
LFI00590
LFI00600
68
-------
c
c
c
c
c
c
c
c
c
c
IF(TOP .LT. SMALL) THEN LFI00610
ZMASS-HPL-HC LFI00620
ELSE IF(BOT .LT. SMALL) THEN LFI00630
ZMASS-0.0 LFI00640
ELSE LFI00650
ZMASS-TOP/BOT-HC LFI00660
ENDIF LFI00670
DEFINE STREAMLINE HEIGHT (HS) FOR COMPUTING TERRAIN FACTORS LFI00680
HS-ZMASS*.5 LFI00690
IF(HS .LT. SMALL*HH .OR. HPL .LE. HC) HS=0. LFI00700
SET UP LENGTH SCALES OF THE CUT-OFF HILL LFI00710
AH-AAXL*ALPHA LFI00720
BH-BAXL*ALPHA LFI00730
DO NOT ALLOW HEIGHT OF STREAMLINE TO EXCEED UPPER LIMIT COMPATIBLE LFI00740
WITH THE FLOW ROUTINE LFI00750
CALL HILROT(AH,BH,DELANG) LFI00760
HASYM - SQRTU.O + LX*LX/(LY*LY)) LFI00770
IF(HASYM .GT. SQR2) HASYM - SQR2 LFI00780
HSMAX - HH * (1.0 + PIBY2*FR/HASYM) LFI00790
HS - AMINKHS, HSMAX) LFI00800
SET UP TZ AND TY GRID OF VALUES LFI00810
NOTE THAT S DENOTES DISTANCE FROM THE SOURCE ALONG THE FLOW, X LFI00820
DENOTES DISTANCE FROM THE CENTER OF THE HILL ALONG THE FLOW, AND LFI00830
XMOD DENOTES DISTANCE FROM THE (CROSSWIND) CREST-LINE ALONG THE FLOW LFI00840
SO
0.0
IF(SO .LT. 0.0)
XO-SO+XSEPL
SET DISTANCE INCREMENT FOR GRID OF (25) POINTS ALONG THE FLOW EQUAL
TO 1/10 THE LENGTH SCALE OF THE HILL IN THE FLOW DIRECTION.
NOTE THAT THIS CHOICE IS RELATED TO THE USE OF MXDPTS-25, SO THAT
THE CODE SHOULD BE CHANGED IF MXDPTS IS OTHER THAN 25.
IF(XO .LT. -LX) THEN
DELTAX - -0.1 * XO
ELSE
DELTAX - 0.1 * LX
ENDIF
DELTAT-DELTAX/UV
TTLZI-l./TTLZ
TO-SO/UV
TOZ-TO+ZTV
TOY-TO+YTV
LFIOD850
LFI00860
LFI00870
LFI00880
LFI00890
LFI00900
LFI00910
LFI00920
LFI00930
LFI00949-
LFI00950
LFI00960
LFI00970
LFI00980
LFI00990
LFI01000
C FZO IS (SIGMA-Z/(SIGMA-W * TO))**2 AT THE UPWIND BASE OF CUT-OFF HILLLFIOIOIO
101
C
C
C
C
C
c
FZO-1./(1.+.5*TOZ*TTLZI)
INITIALIZE OUTPUT ARRAYS OF Tz**2 AND Ty**2
DO 101 K-l,MXDPTS
ATZSQ(K) - 1.0
ATYSQ(K) - 1.0
SG (K) -SO+K*DELTAX
CONTINUE
SKIP FLOW CALC IF THE PLUME CENTERLINE MISSES THE HILL
IF(ABS(YSEPL) .LT. 2.0*LY) THEN
OBTAIN TZ AND TY FACTORS
BOTZ-0.
BOTY-0.
LOOP OVER THE DOWNWIND GRID POINTS (MXDPTS)
DO 10 K-l,MXDPTS
IF(K .EQ. 1) THEN
NOTE— TIME AT THE Kth POINT FOR COMPUTING TZ IS DENOTED AS
TIME AT THE (K-l) POINT FOR TZ IS DENOTED AS TKM1Z
TKZ
LFI01020
LFI01030
LFI01040
LFI01050
LFI01060
LFI01070
LFI01080
LFI01090
LFI01100
LFI01110
LFI01120
LFI01130
LFI01140
LFI01150
LFI01160
LFI01170
LFI01180
LFI01190
LFI01200
69
-------
C WHEN SCALED BY THE TIME TO THE BASE OF THE HILL (TOZ),ADD 'P'
TKM1Z=TOZ
TKM1ZP-1.
TIM1YP-1.
ENDIF
TKZ-TOZ+K*DELTAT
TKY-TOY+K*DELTAT
C (SCALE TIMES BY TOZ OR TOY TO AVOID DIFFERENCING SQUARES OF LARGE #S)
TKZP-TKZ/TOZ
TKYP-TKY/TOY
C FZK IS (SIGMA-Z/(SIGMA-W * TO))**2 AT THE Kth POINT
FZK-TKZP*TKZP/(1.+.5*TKZ*TTLZI)
C OBTAIN THE STRAIN FACTORS AT THE MID-POINT OF THE INTERVAL
XM-SG(K)-.5 *DELTAX+XSEPL
CALL PATH(THM,TLM,TOM,XM,YSEPL,HS)
C
C
C
IF NEGATIVE OR ZERO T FACTORS, DO NOT MODEL THIS HOUR
C
C
IFLOW - 0
IF(THM .LE. 0.0 .OR. TLM .LE.
IFLOW - 1
RETURN
ENDIF
COMPUTE SQUARE OF THE STRAIN FUNCTION
0.0 .OR. TOM .LE. 0.0) THEN
VERTICAL-B3SQ ; LATERAL-B2SQ
EQN. A-5
IF(THM .GT. 16.) THM - 16.
B3SQ-EXPC-2.*(THM-1.))
IF(TLM .GT. 16.) TLM - 16.
B2SQ-EXP(-2.*(TLM-1.))
TSW-TOM
TSV-1.
TSWBYH-TSW/THM
C COMPUTE 1/LAGRANGIAN TIMESCALE FOR THIS POINT EQN. A-9
TTLZKI-TSTRAT/SQRT (THM) +TSWBYH*TNEUT*HPL/ (ZMASS-t-HC)
C COMPUTE THE FACTORS TZ**2 AND TY**2
C USE EQNS. A-6, A-7, A-10, AND A-ll; TURN EXPRESSIONS FOR 1/TZ AND
C 1/TY 'OVER', AND DIVIDE TOP AND BOTTOM BY SIGMA-W * TOZ (OR
C SIGMA-V * TOY).
TOPZ-FZK-FZO
TOPY-TKYP*TKYP-1.
BOTZ-BOTZ+B3SQ*TSW*TSW* (TKZP*TKZP/ (1. +. 5-*TKZ*TTLZKI) -
* TKM1ZP*TXM1ZP/(1.+.5*TKM1Z*TTLZKI))
BOTY-BOTY+B2SQ*TSV*TSV*(TKYP*TKYP-TXM1YP*TKM1YP)
ATZSQ(K)-TOPZ/BOTZ
ATYSQ(K)-TOPY/BOTY
C RESET THE LOWER TIME VALUES FOR THE NEXT INTERVAL IN K
TKM1Z-TKZ
TKM1ZP-TXZP
TKM1YP-TKYP
10 CONTINUE
ENDIF
RETURN
END
LFI01210
LFI01220
LFI01230
LFI01240
LFI01250
LFI01260
LFI01270
LFI01280
LFI01290
LFI01300
LFI01310
LFI01320
LFI01330
LFI01340
LFI01350
LFI01360
LFI01370
LFI01330
LFI01390
LFI01400
LFI01410
LFI01420
LFI01430
LFI01440
LFI01450
LFI01460
LFI01470
LFI01480
LFI01490
LFI01500
LFI01510
LFI01520
LFI01530
LFI0154JQ-
LFI01550
LFI01560
LFI01570
LFI01580
LFI01590
LFI01600
LFI01610
LFI01620
LFI01630
LFI01640
LFI01650
LFI01660
LFI01670
LFIO:L680
LFI01690
LFI01700
LFI01710
LFI01720
LFI01730
70
-------
~~
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
SUBROUTINE LINES ( NLINC, IFIAG, NEWPGE )
PURPOSE:
THIS ROUTINE KEEPS TRACK OF THE NUMBER OF USED PRINTOUT LINES.
IF A NEW PAGE IS NEEDED THE PAGE ROUTINE WILL BE CALLED.
LIMITATIONS:
MAX LINES PER PAGE IS 57
ARGUMENTS:
PASSED:
NLINC INT NUMBER OF LINES
IFLAG INT FLAG INDICATING WHETHER RUN TITLE IS PRINTED
0=NO, 1=YES
RETURNED:
NEWPGE INT FIAG INDICATING IF NEW PAGE 0=NO, 1=XES
COMMON BUOCKS: HEAD
INPUT: NONE
OUTPUT: PAGE HEADER IF NLINES EXCEEDS MAXLIN
CALLING PROGRAMS: CTDM (MAIN) , INPSOR, INPREC, MAP
EXTERNAL ROUTINES CALLED: PAGE
INCLUDE 'PARAMS.INC1
INCLUDE 'HEAD.CMN'
DEFINE ARGUMENTS
INTEGER NLINC, IFLAG, NEWPGE
DEFINE LOCAL VARIABLES
INTEGER NO, VES
DATA NO/ O/
DATA YES/ V
NLINES - NLINES + NUNC
IF( NLINES .GT. MAXLIN ) THEN
NEWPGE » VES
CALL PAGE( IFLAG )
NLINES - 2 + 2*IFLftG + NLINC
ELSE
NEWP3E » NO
ENDIF
RETURN
END
LIN00010
— LIN00020
LIN00030
LIN00040
LTN00050
LIN00060
LIN00070
LIN00080
LIN00090
LIN00100
LEN00110
LIN00120
LTN00130
UN00140
LIN00150
LIN00160
LTN00170
LIN00180
LIN00190
LIN00200
LTN00210
LIN00220
LIN00230
UN00240
LIN00250
UN00260
LIN00270
LTN00280
-LIN00290
LIN00300
LIN00310
LIN00320
LIN00330
LIN00340
LIN00350
LIN00360
UN00370
LIN00380
LIN00390
LIN00400
UN00410
LIN00420
LIN00430
LIN00440
LIN00450
LIN00460
LD100470
LIN00480
LIN00490
LIN00500
LTN00510
LIN00520
71
-------
INTEGER FUNCTION LSTAB( EL, 2RO)
C FUNCTION: LSTAB
C
C PURPOSE: THIS FUNCTION CALCULATES A P-G STABILITY CLASS GIVEN THE
C MONIN-OBUKHOV LENGTH (L) AND THE SURFACE ROUGHNESS
C LENGTH (20) .
C
C ASSUMPTIONS: THE DIVIDING LINES BETWEEN CATEGORIES ARE ASSUMED TO BE
C LINEAR.
C
C LIMITATIONS: THIS FUNCTION IS ONLY VALID FOR 0.01 <- ZO <- 0.5(M).
C HOWEVER, RESULTS ARE EXTENDED TO OTHER VALUES OF ZO BY
C USING ZO - 0.01 IF ZO < 0.01 M, AND BY USING 20 - 0.5
C IF ZO > 0.5 M.
C
C ARGUMENTS
C PASSED:
C EL REAL MONIN-OBUKHOV LENGHT (M)
C ZRO REAL SURFACE ROUGHNESS LENGTH (M)
C RETURNED FUNCTION VALUE:
C LSTAB INT P-G STABILITY CATEGORY 1-A, 2-B, ETC.
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTERNAL FUNCTIONS:
C XL - EQUATION OF DIVIDING LINE BETWEEN P-G STABILITY CLASSES
C
C INTRINSIC FUNCTIONS: ALOG
C
C REFERENCES:
C COLDER, D. (1972): RELATIONS AMONG STABILITY PARAMETERS IN THE
C SURFACE LAYER, BOUNDARY-LAYER METEOROLOGY, 3:56
C
C
REAL EL, ZRO
C
REAL Y, XM, B
C
XL(Y,XM,B)»XM/(ALOG(Y)-B)
C
ZO - ZRO
IF(ZO .GT. 0.5) ZO - 0.5
IF(ZO .LT. 0.01) ZO - 0.01
IF (EL .LT. 0.0) THEN
XEL - -EL
IF(XEL .LE. XL(ZO,-70.0,4.35)) THEN
C STABILITY A
LSTAB-1
ELSE IF (XEL .LE. XL(ZO, -85.2, 0. 502) ) THEN
C STABILITY B
LSTAB-2
ELSE IF (XEL .LE. XL(ZO, -245. ,0.050) ) THEN
C STABILITY C
LSTAB-3
ELSE
C STABILITY D
LST00010
LST00030
LST00040
LST00050
LST00060
LST00070
LST00080
LST00090
LST00100
LST00110
LST00120
LST00130
LST00140
LST00150
LST00160
LST00170
LST00180
LST00190
LST00200
LST00210
LST00220
LST00230
LST00240
LST00250
LST00260
LST00270
LST00280
LST00290
LST00300
LST00310
LST00320
LST00330
LST00340-
.LST00350
LST00360
T o*finm 1 f\
— L«STO037O
LST00380
LST00390
LST00400
LST00410
LST00420
LST00430
LST00440
LST00450
LST00460
LST00470
LST00480
LST00490
LST00500
LST00510
LST00520
LST00530
LST00540
LSTOCI550
LST00560
LST00570
LST00580
LST00590
LSTOCI600
72
-------
LSTAB-4 LST00610
ENDIF LST00620
ELSE LST00630
IF(EL- .GE. XL(ZO,-327.,0.627) ) THEN LST00640
STABILITY D LST00650
LSTAB-4 LST00660
ELSE IF(EL .GE. XL(ZO,-70.0,0.295)) THEN LST00670
STABILITY E LST00680
LSTAB-5 LST00690
ELSE LST00700
STABILITY F LST00710
LSTAB-6 LST00720
ENDIF LST00730
ENDIF LST00740
LST00750
RETURN LST00760
END LST00770
73
-------
SUBROUTINE LVDF (Z , DUM , DUM1 , DUM2 , DUM3P, ZSMHC, ZSPHC, ZFAC)
C PURPOSE: COMPUTES THE VERTICAL DISTRIBUTION FACTOR (VDF) FOR LIFT
C
C ARGUMENTS:
C PASSED:
C Z REAL HEIGHT ABOVE THE SURFACE (M)
C DUM REAL I/ (2*SIGZE**2) (M**-2)
C DUM1,2,3P REAL TERMS IN ARGUMENT OF ERFS IN VDF EXPRESSION
C ZSMHC REAL ZS - HC (M)
C ZSPHC REAL ZS + H (M)
C RETURNED:
C ZFAC REAL VERTICAL DISTRIBUTION FACTOR
C
C I/O: NONE
C
C CALLING ROUTINE: LIFT
C
C EXTERNAL ROUTINES: ERF
C
C INTRINSIC FUNCTIONS: EXP
C
C INCLUDE FILES: NONE
C
C COMMON BLOCKS: NONE
C
C
C DEFINE ARGUMENTS
REAL Z, DUM, DUM1, DUM2 , DUM3P, ZSMHC, ZSPHC, ZFAC
C
C DEFINE LOCAL VARIABLES
REAL ARG1, ARG2 , ARG3 , ARG4, DUM3 , ERF1, ERF2 , ERF3 , ERF4 ,
* Tl, T2, T3, T4
C
C . ...EQN. 39B
DUM3-DUM3P*Z
ERT1-1 . -ERF ( -DUM1-DUM3 )
ERF2-1 . -ERF ( -DUM1+DUM3 )
ERF3-1 . -ERF (DUM2-DUM3 )
ERF4-1 . -ERF ( DUM2+DUM3 )
ARG1-DUM* (Z-ZSMHC) **2
ARG2-DUM* (Z+ZSMHC) **2
ARG3-DUM* (Z+ZSPHC) **2
ARG4-DUM* (Z-ZSPHC) **2
Tl-0.
T2-0.
T3-0.
T4-0.
IF(ARG1 .LT. 30.) T1-ERF1*EXP(-ARG1)
IF(ARG2 .LT. 30.) T2-ERF2*EXP(-ARG2)
IF(ARG3 .LT. 30.) T3-ERF3*EXP(-ARG3)
IF(ARG4 .LT. 30.) T4-ERF4*EXP(-ARG4)
ZFAC-T1+T2+T3+T4
RETURN
END
LVD00010
LVD00030
LVD00040
LVD00050
LVD00060
LVD00070
LVD00080
LVD00090
LVD00100
LVD00110
LVD00120
LVD00130
LVD00140
LVD00150
LVD00160
LVD00170
LVD00180
LVD00190
LVD00200
LVD00210
LVD00220
LVD00230
LVD00240
LVD00250
LVD00260
LVDOCI280
LVDOCI290
LVD00300
LVD00310
LVD00320
LVD00330
LVD00340_
LVD00350
LVD00360
LVD00370
LVD00380
LVD00390
1 LVD00400
LVD00410
LVD00420
LVD00430
LVD00440
LVD00450
LVD00460
LVD00470
LVD00480
LVD00490
LVD00500
LVD00510
LVD00520
LVD00530
LVD00540
LVD00550
LVD00560
-------
SUBROUTINE MAP
C PURPOSE: THIS ROUTINE CREATES A MAP OF THE SOURCES AND RECEPTORS
C RELATIVE TO EACH OTHER. DISTANCES IN THE X AND Y
C DIRECTIONS ARE SET EQUAL USING PARAMETER XYFACT.
C XYFACT IS SET TO 1.2 FOR STANDARD PRINTER OUTPUT,
C WHICH HAS 6 LINES AND 10 COLUMNS PER INCH. MAP
C PLOTS EVERY OTHER COLUMN, OR 5 SEPARATED COLUMNS PER
C INCH. THEREFORE, A 60 X 60 MAP REQUIRES 10 INCHES IN
C THE VERTICAL AND 12 INCHES IN THE HORIZONTAL, GIVING
C AN XYFACT OF 1.2.
C
C ASSUMPTIONS:
C SOURCE AND RECEPTOR HORIZ. COORDINATES ARE IN THE SAME UNITS
C
C LIMITATIONS:
C A MAXIMUM OF 60 COLUMNS AND 60 ROWS ARE USED TO PRODUCE THE
C MAP (SEE PARAMETERS MAXX AND MAXY) . FOR 80 COLUMN
C PRINTING, THE MAP CONSISTS OF 40 COLUMNS AND 40 ROWS.
C THE VARIABLE IWIDTH IS CURRENTLY SET TO 0 TO FORCE
C 80 COLUMN PRINTING.
C
C ARGUMENTS: NONE
C
C I/O:
C INPUT: NONE
C OUTPUT: UNIT-IOUT
C PRINTOUT OF SOURCE, RECEPTOR, AND HILL LOCATIONS
C
C CALLING ROUTINES: CTDM (MAIN)
C
C EXTERNAL ROUTINES: PAGE
C
C INTRINSIC FUNCTIONS: AMAX1 AMIN1 FLOAT INT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: 10 PARAMS RECEPT STACKS
C
C
PARAMETER ( MAXX - 60)
PARAMETER ( MAXY - 60)
PARAMETER ( MAXXY - 3600)
PARAMETER( XYFACT - 1.2)
C
INCLUDE ' PARAMS . INC '
INCLUDE 'IO.CMN'
INCLUDE ' PARAMS . CMN '
INCLUDE ' RECEPT . CMN '
INCLUDE 'STACKS. CMN1
C
C DEFINE LOCAL VARIABLES
REAL RXMIN, RYMIN, RXMAX, R7MAX, SXMIN, SYMIN,
1 SXMAX, SYMAX, XMIN, YMIN, XMAX, YMAX,
2 DX, DY, XFACT, YFACT
INTEGER NR, NS, NO, I, J
CHARACTER*! BUFF (MAXX, MAXY) ,S, PLUS,H, V,HILSYM(0:MAXHIL)
C
C XYFACT IS THE RATIO FOR THE MAPPED AREA ON PAPER OF THE
MAP00010
MAP00030
MAP00040
MAP00050
MAP00060
MAP00070
MAP00080
MAP00090
MAP00100
MAP00110
MAP00120
MAP00130
MAP00140
MAP00150
MAP00160
MAP00170
MAP00130
MAP00190
MAP00200
MAP00210
MAP00220
MAP00230
MAP00240
MAP00250
MAP00260
MAP00270
MAP00280
MAP00290
MAP00300
MAP00310
MAP00320
MAP00330
MAP0034C-
MAP00350
MAP00360
MAP00370
MAP00380
MAP00390
MAP00410
MAP00420
MAP00430
MAP00440
MAP00450
MAP00460
MAP00470
MAP00480
MAP00490
MAP00500
MAP00510
MAP00520
MAP00530
MAP00540
MAP00550
MAP00560
MAP00570
MAP00580
MAP00590
MAP00600
75
-------
c
c
c
c
c
10
c
20
C
C
c
c
c
c
c
1
2
HORIZONTAL SIDE TO THE VERTICAL SIDE.
DATA BUFF/HAXXY*' '/
DATA S/1*'// PLUS/'+'/, H/'-'/, V/'|'/
DATA HILSYM/ ' 0 ' , ' 1 ' , ' 2 ' , ' 3 ' , ' 4 ' , ' 5 ' , ' 6 ' , ' 7 ' , ' 8 ' , '9 ' , ' A1
'B', 'C', 'D', '£', 'F', 'G1, 'H', 'I', 'J', 'K1, 'L', 'M',
'W ,'0* ,fP' ,'Q* ,'R' ,'S' ,'T ,'W ,'W ,'W ,•*' ,'V ,'Z'
DATA NO/0/
DETERMINE REQUIRED MAP COVERAGE (MIN, MAX VALUES OF X,Y)
RXMIN-RECPT(1,1)
RYMIN-RECPT(2,1)
RXMAX-RECPT(1,1)
RYMAX=R£CPT(2,1)
DO 10 NR-1,NRECPT
IF(RXMIN .GT. RECPT(1,KR))
IF(RYMIN .GT. RECPT(2,NR))
IF(RXMAX .LT. RECPT(1,NR))
IF(RYMAX .LT. RECPT(2,NR))
CONTINUE
SXMIN-SOURCE(1,1)
SYMIN-SOURCE(2,1)
SXMAX-SOURCE(1,1)
SYMAX-SOURCE(2,1)
DO 20 NS-1,NSTACK
IF(SXMIN .GT. SOURCE(1,NS))
IF(SYMIN .GT. SOURCE ( 2, NS) )
IF(SXMAX .LT. SOURCE(1,NS))
IF(SYMAX .LT. SOURCE ( 2 , NS ))
CONTINUE
RXMIN-RECPT(1,NR)
RYMIN-RECPT(2,NR)
RXMAX-RECPT(1,NR)
RYMAX-RECPT(2,NR)
SXMIN-SOURCE(1,NS)
SYMIN-SOURCE(2,NS)
SXMAX-SOURCE(1,NS)
SYMAX-SOURCE(2,NS)
XMIN-AMIN1(RXMIN,SXMIN) - 0.001
YMIN-AMIN1(RYMIN,SYMIN) - 0.001
XMAX-AMAX1(RXMAX,SXMAX) + 0.001
YMAX-AMAX1(RYMAX,SYMAX) + 0.001
DX-XMAX-XMIN
DY-YMAX-YMIN
«
ADJUST TOTAL RANGE IN X OR Y SO THAT MAP WILL FIT ON A PAGE
IF(DX .GT. XYFACT*DY) THEN
DXMAX - OX
DYMAX - DX/XYFACT
ELSE
DXMAX - XYFACT*DY
DYMAX - DY
ENDIF
IF(DXMAX.EQ.O.O) RETURN
XMID - (XMAX + XMIN)/2.0
YMID - (YMAX + YMIN)/2.0
XMIN - XMID - DXMAX/2.0
XMAX - XMID + DXMAX/2.0
YMI» - YMID - DYMAX/2.0
YMAX - YMID + DYMAX/2.0
ASSIGN NUMBER OF ROWS AND COLUMNS
IWIDTH - 0
MAP00610
MAP00620
MAP00630
MAP00640
MAP00650
MAP00660
MAP00670
MAP00680
MAP00690
MAP00700
MAP00710
MAP00720
MAPCI0730
MAP00740
MAP00750
MAP00760
MAP00770
MAP00780
MAP00790
MAP00800
MAP00810
MAP00820
MAP00830
MAP00840
MAP00850
MAP00860
MAP00870
MAP00880
MAP00890
MAP00900
MAP00910
MAP00920
MAP00930
MAP0094fl_
MAP00950
MAP00960
MAP00970
MAP00980
MAP00990
MAP01000
MAP01010
MAP01020
MAP01030
MAP01040
MAP01050
MAP01060
MAP01070
MAP01080
MAP01090
MAP011QO
MAP01110
MAP01120
MAP01130
MAP01140
MAP01150
MAP01160
MAP01170
MAP01180
MAP01190
MAP01200
76
-------
c
c
c
c
c
c
c
c
c
c
c
c
22
C
C
C
25
C
C
c
c
c
c
c
c
c
c
c
30
c
c
IWIDTH IS A VARIABLE NOT CURRENTLY USED; IT WAS DESIGNATED AS
FOR 80-COLUMN MAP OUTPUT AND 1 FOR 132-COLUMN OUTPUT. HERE,
WIDTH IS SET TO 0, BUT CODE FOR IWIDTH - 1 IS RETAINED FOR
POTENTIAL FUTURE APPLICATIONS.
IF(IWIDTH .EQ. 0) THEN
MAXY1 - 40
MAXX1 - 40
ELSE
MAXY1 - MAXY
MAXX1 - MAXX
ENDIF
PUT "+" AT MAP CORNERS IN ARRAY BUFFER
BUFF(1,1) - PLUS
BUFF(1,MAXY1) - PLUS
BUFF(MAXX1,1) - PLUS
BUFF(MAXX1,MAXY1) - PLUS
PUT '-' AT BOTTOM AND TOIP MAP EDGES
IF(MAXX1 .GT. 2) THEN
DO 22 I - 2,MAXX1-1
BUFF(1,1) - H
BUFF(I,MAXY1) - H
CONTINUE
ENDIF
PUT •|' AT MAP SIDES
IF(MAXY1 .GT. 2) THEN
DO 25 I - 2,MAXY1-1
BUFF(1,I) - V
BUFF(MAXX1,I) - V
CONTINUE
ENDIF
XFACT, YFACT ARE GRID DX,DY
XFACT - FLOAT(MAXX1)/DXMAX
YFACT - FLOAT(MAXY1)/DYMAX
PLOT RECEPTOR LOCATIONS. NOT THAT MAP ROWS (J) START AT TOP OF
PAGE, BUT MINIMUM Y VALUES ARE AT MAP BOTTOM.
DO 30 NR-1,NRECPT
I-IFIX((RECPT(1,NR)-XMIN)*XFACT+1.0)
IF(I .GT. MAXX1) I-MAXX1
J-MAXY1-(IFIX((RECPT(2,NR)-YMIN))*YFACT)
IF(J .LT. 1) J-l
PLOT HILL NUMBER AT EACH RECEPTOR POINT (USE LETTERS A-Z FOR
10-35)
BUFF(I,J)-HILSYM(NRHILL(NR))
CONTINUE
PLOT SOURCE LOCATIONS ('*')
MAP01210
MAP01220
MAP01230
MAF01240
MAP01250
MAP01260
MAP01270
MAP01280
MAP01290
MAP01300
MAP01310
MAP01320
MAP01330
MAP01340
MAP01350
MAP01360
MAP01370
MAP01380
MAP01390
MAP01400
MAP01410
MAP01420
MAP01430
MAP01440
MAP01450
MAP01460
MAP01470
MAP01480
MAP01490
MAP01500
MAP01510
MAP01520
MAP01530
MAP01540-
MAP01550
MAP01560
MAP01570
MAP01580
MAP01590
MAP01600
MAP01610
MAP01620
MAP01630
MAP01640
MAP01650
MAP01660
MAP01670
MAP01680
MAP01690
MAP01700
MAP01710
MAP01720
MAP01730
MAP01740
MAP01750
MAP01760
MAP01770
MAP01780
MAP01790
MAP01800
77
-------
40
C
C
C
C
C
C
6000
6005
1
2
1
2
6010
6015
DO 40 NS-1,NSTACK
I-IFIX( (SOURCE (1,NS) -XMIN) *XFACT-i-l. 0)
IF(I .GT. MAXX1) I-MAXX1
J-MAXY1-(IFIX((SOURCE(2,NS)-YMIN))*YFACT)
IF(J .LT. 1) J-l
BUFF(I,J)-S
CONTINUE -
CALL PAGE(NO)
WRITE OUT ENTIRE MAP
6000, 6010 FORMATS COULD BE USED FOR 132-COLUMN OUTPUT
IF(IWIDTH.EQ.l) THEN
WRITE(IOUT,6000) XMIN,XMAX,YMIN,YMAX
WRITE(IOUT, 6010) BUFF
ELSE
WRITE(IOUT,6005) XMIN,XMAX,YMIN,YMAX
WRITE(IOUT,6015) ((BUFF(I,J),1-1,40),J-1,40)
ENDIF
RETURN
FORMAT(IX,'MAP EDGES: XMIN - ',F8.0,', XMAX - ',F8.0,
', YMIN - ',F8.0,', YMAX - ',F8.0,'; * - SOURCE, ',
•RECEPTORS SHOWN BY HILL # (0-9,A-Z)')
FORMAT(3X,'MAP EDGES: XMIN - ',79.0,', XMAX - ',F8.0,
', YMIN - ',F8.0,', YMAX - ',F8.0,//,15X,' * - SOURCE,
•RECEPTORS SHOWN BY HILL # (0-9,A-Z)',//)
FORMAT(6X,60(1X,A1))
FORMAT(40(1X,A1))
END
MAP01810
MAP01820
MAP01830
MAP01840
MAP01850
MAP01860
MAP01870
MAP01880
MAP01890
MAP01900
MAP01910
MAP01920
MAP01930
MAi-01940
MAP01950
MAP01960
MAP01970
MAP01980
MAP01990
MAP02000
MAP02010
MAP02020
MAP02030
MAP02040
MAP02050
MAP02060
MAP02070
MAP02080
MAP02090
MAP02100
MAP02110
MAP02120
78
-------
SUBROUTINE MIX (DELS, UBYN, H2)
C PURPOSE: ESTIMATES THE DEPTH OF A MIXED LAYER THAT DEVELOPS
C AT THE HILL SURFACE ABOVE HC
C
C ARGUMENTS :
C PASSED:
C DELS REAL DISTANCE ALONG THE FLOW FROM THE UPWIND EDGE
C OF THE CUT-OFF HILL ("DELTA S") (M)
C UBYN REAL WIND SPEED / BRUNT-VAISALA FREQUENCY (M)
C RETURNED:
C H2 REAL HEIGHT OF TOP OF MIXING LAYER ABOVE THE
C SURFACE OF THE HILL (M)
C
C I/O: NONE
C
C CALLING ROUTINE: LIFT
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: ABS ALOG AMAX1 AMIN1
C
C INCLUDE FILES: PARAMS.INC
C
C~ COMMON BLOCKS: CONST PASVAL SFCMET
C
C
PARAMETER ( MAXITR - 500)
C
INCLUDE ' PARAMS . INC '
INCLUDE ' PASVAL . CMN '
INCLUDE ' CONST . CMN '
INCLUDE 'SFCMET. CMN'
C
C DEFINE ARGUMENTS
REAL DELS, UBYN, H2
C
C DEFINE LOCAL VARIABLES
REAL DUM, HI, HLOG, HLOG2, HLOG3, SDELS, TEST, THIRD, UBYNI
C
THIRD-1./3.
AVGOLD - 0.0
UBYNI-l./UBYN
C SCALE THE DISTANCE BY THE LENGTH SCALE U/N
SDELS-DELS *UBYNI
C ITERATE TO FIND HEIGHT OF MIXED LAYER AT DELS
Hl-0 . 1*DELS
NITER - 0
C
C EQN. A- 14
10 H1ZOI - AMAX1(H1/ZOHILL,2.0)
ZOH1I3-0.
IF(H1ZOI .LT. 10.) ZOH1I3-1./(H1ZOI*H1ZOI*H1ZOI)
HLOG-ALOG(HIZOI)
HLOG2-HLOG*HLOG
HLOG3-HLOG*HLOG2
DUM-HLOG3-HLOG2+THIRD*2 . * (HLOG-THIRD* ( 1 . -ZOH1I3 ) )
H2-( (SDELS/DUM) **THIRD) *UBYN
C
MIX00010
m lyiT vrt f\ c\ i f\
" nlAUUUZU
MIX00030
MIX00040
MIX00050
MIX00060
MIX00070
MIX00080
MIX00090
MIX00100
MIX00110
MIX00120
MIX00130
MIX00140
MIX00150
MIX00160
MIX00170
MIX00180
MIX00190
MIX00200
MIX00210
MIX00220
MIX00230
MIX00240
MIX00250
MIX00260
MIX00230
MIX00290
MIX00300
MIX00310
MIX00320
MIX00330
MIX0034«T
MIX003SO
MIX00360
MIX00370
MIX00380
MIX00390
M1X00400
MIX00410
MIX00420
MIX00430
MIX00440
MIX00450
MIX00460
MIX00470
MIX00480
MIX00490
MIX00500
MIX00510
MIX00520
MIX00530
MIX00540
MIX00550
MIX00560
MIX00570
MIX00580
MIX00590
MIX00600
79
-------
c
c
c
c
c
c
c
20
ASSUME CONVERGENCE IF WITHIN ZO OF PREVIOUS GUESS
IF CHANGE OF AVERAGES OF PRESENT AND PREVIOUS GUESSES IS LESS
ZO, USE AVERAGE TO SET NEW GUESS.
TEST =• ABS(H1-H2)
IF(TEST .LE. ZOHILL) GO TO 20
AVG - 0.5 * (HI + H2)
IF(ABS(AVG - AVGOLD) .LT. ZOHILL) THEN
IF(AVG .GE. DELS) THEN
H2 - DELS
RETURN
ENDIF
HI - AVG
ELSE
H1-H2
ENDIF
AVGOLD - AVG
NITER - NITER + 1
IF(NITER .GT. MAXITR) STOP 'NO CONVERGENCE IN MIX ROUTINE1
GO TO 10
DO NOT ALLOW GROWTH OF MIXED LAYER TO EXCEED DELTA-S
H2-AMIN1(H2,DELS)
RETURN
END
MIX00610
THANMIX00620
MIX00630
MIX00640
MIX00650
MIX00660
MIX00670
MIX00680
MIX00690
MIX00700
MIX00710
MIXCI0720
MIX00730
MIX00740
MIXOOV50
MIX00760
MIX00770
MIX00780
MIX00790
MIX00800
MIX00810
MIX00820
MIX00830
MIX00840
MIX00850
MIX00860
80
-------
SUBROUTINE MUNU(X, Y, A, B,MU,NU)
C PURPOSE: COMPUTES THE ELLIPTIC COORDINATES ASSOCIATED WITH THE
C POINT (X,Y) WHERE THE X-AXIS IS ALIGNED WITH THE MAJOR
C AXIS OF THE ELLIPSE. (INVERT EQNS. A-48)
C
C ARGUMENTS:
C PASSED:
C X, Y REAL CARTESIAN COORDINATES (M)
C A, B REAL MAJOR, MINOR SEMI-AXIS LENGTHS (M)
C RETURNED:
C MU, NU REAL ELLIPTIC COORDINATES
C
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: ABS ALOG ASIN COS SIN SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' CONST. CMN1
C
C DEFINE ARGUMENTS
REAL A, B, MU, NU, X, Y
C
C DEFINE LOCAL VARIABLES
REAL ABSX, ABSY, AR, ARC, ARSQ, BI, COSNU, DUM1, DUM2 , DUM3 ,
* R, RSQ, SINNU, XP, XPSQ, YP, YPSQ
C
BI-l./B
AR-A*BI
ARSQ-AR*AR
C SCALE LENGTHS BY THE MINOR SEMI -AXIS LENGTH
XP-X*BI
YP-Y*BI
ABSX-ABS(XP)
ABSY-ABS(YP)
XPSQ-XP*XP
YPSQ-YP*YP
C IF POINT(X,Y) LIES VERY NEAR AN AXIS, PLACE IT ON THE AXIS
IF (ABSX .LT. SMALL) THEN
XP-0.
ABSX-0.
ENDIF
IF (ABSY .LT. SMALL) THEN
YP-0.
ABSY-0.
ENDIF
IF(XP .EQ. 0. .AND. YP .EQ. 0.) THEN
NU-PIBY2
C BECAUSE MU IS NOT USED FOR POINTS ON THE HILL,
C RETURN A NULL AT THE CREST
MUN00010
MUN00030
MUN00040
MUN00050
MUN00060
MUN00070
MUN00080
MUN00090
MUN00100
MUN00110
MUN00120
MUN00130
MUN00140
MUN00150
MUN00160
MUN00170
MUN00180
MUN00190
MUN00200
MUN00210
MUN00220
MUN00230
MUN00240
MUN00250
—UTnmft'j £n
~nuriuuAou
MUN00270
MUN00280
MUN00290
MUN00300
MUN00310
MUN00320
MUN00330
MUN00348-
MUN00350
MUN00360
MUN00370
MUN00380
MUN00390
MUN00400
MUN00410
MUN00420
MUN00430
MUN00440
MUN00450
MUN00460
MUN00470
MUN00480
MUN00490
MUN00500
MUN00510
MUN00520
MUN00530
MUN00540
MUN00550
MUN00560
MUN00570
MUN00580
MUN00590
MUN00600
ffl
81
-------
MU-0.
RETURN
ENDIF
RSQ=XPSQ+YPSQ
R-SQRT(RSQ)
CALCULATE NU
DUM1-ARSQ-1.
IF(DUM1 .LT. SMALL) THEN
NU=ASIN(ABSY/R)
ELSE
DUM2-1.-RSQ/DUM1
DUM3-0. 5* (DUM2+SQRT (DUM2**2+4 . *YPSQ/DUM1) )
IF(DUM3 .LT. 0. .AND. DUM3 .GE. -SMALL) THEN
.AND. (ARG-l.).LE. SMALL) ARG-1.
ELSE
AROSQRT(DUM3)
IF((ARG-1.) .GT.
NU-ASIN(ARG)
ENDIF
ENDIF
IF(XP .LT. 0.) NO-PI -NO
IF(YP .LT. 0.) NO— NO
COSNU-COS(NU)
SINNU-SIN(NO)
CALCULATE MO
IF(ABS(SINNU) .LE. SMALL) THEN
MO-ALOG ( (ABSX+SQRT (XPSQ+1 . -ARSQ) ) / ( AR+1 . ) )
ELSEIF(ABS(COSNU) .LE. SMALL) THEN
MU-ALOG ( ( ABSY-t-SQRT ( YPSQ+ARSQ-1 . ) ) / ( AR+1 . ) )
ELSE
MO-ALOG ( (XP/COSNO+YP/SINNO) / (AR+1 . ) )
ENDIF
RETORN
END
MUN00610
MUN00620
MUN00630
MUN00640
MUN00650
MUN00660
MUN00670
MUN00680
MUN00690
MUN00700
MUN00710
MUN00720
MUN00730
MUN00740
MON00750
MUN00760
MUN00770
MUN00780
MUN00790
MUN00800
MON00810
MUNOOS20
MUN00830
MUN00840
MON00850
MUN00860
MON00870
MUN00880
MUN00890
MON00900
MUN00910
MUN00920
MUN00930
MUN00940-
82
-------
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
6010
6020
SUBROUTINE PAGE( IFLAG)
PURPOSE:
THIS ROUTINE SKIPS TO A NEW PAGE AND WRITES A PAGE HEADER.
LIMITATIONS :
PROGRAM VERSION NUMBER AND REVISION DATE ARE SPECIFIED HERE.
ARGUMENTS :
PASSED:
IFLAG INT FLAG INDICATING WHETHER RUN TITLE IS PRINTED
0*NO, 1=YES
RETURNED: NONE
I/O:
INPUT: NONE
OUTPUT: PAGE HEADER OF MODEL VERSION ID AND TITLE OF RUN.
CALLING PROGRAMS: CTDM (MAIN), INPSOR, INPREC, MAP
EXTERNAL ROUTINES: NONE
INCLUDE FILES: PARAMS.INC
COMMON BLOCKS: IO HEAD
INCLUDE ' PARAMS . INC '
INCLUDE 'IO.CMN'
INCLUDE ' HEAD . CMN '
DEFINE ARGUMENTS
INTEGER IFLAG
DEFINE LOCAL VARAIBLES
INTEGER YES
CHARACTER* 4 VER
CHARACTER*8 REV, MOD
DATA YES/ I/
' DATA VER/ 'l.OO1/
DATA REV/ ' 10/15/87 '/
DATA MOD/ 'CTDM '/
NPAGE - NPAGE + 1
NLINES - 2
WRITE (IOUT, 6010) MOD, VER, REV, NPAGE
IF (IFLAG .EQ. YES) THEN
WRITE (IOUT, 6020) TITLE
NLINES - NLINES + 2
ENDIF
RETURN
FORMAT( 'I1, A8,T22, 'VERSION ' , A4, 6X, 'REV. DATE ',A8,
* T73, 'PAGE1, IX, I3/)
FORMAT (' ',20A4/)
END
PGE00010
PGE00030
PGE00040
PGE00050
PGE00060
PGE00070
PGE00080
PGE00090
PGE00100
PGE00110
PGE00120
PGE00130
PGE00140
PGE00150
PGE00160
PGE00170
PGE00180
PGE00190
PGE00200
PGE00210
PGE00220
PGE00230
PGE00240
PGE00250
PGE00260
or* v f\ rt *5 "7 f\
r \jCt\j\J 4 7 U
PGE00280
PGE00290
PGE00300
PGE00310
PGE00320
PGE00330
PGE00340
PGE00350
PGE00360
PGE00370
PGE00380
PGE00390
PGE00400
PGE00410
PGE00420
PGE00430
PGE00440
PGE00450
PGE00460
PGE00470
PGE00480
PGE00490
PGE00500
PGE00510
PGE00520
PGE00530
PGE00540
PGE00550
PGE00560
83
-------
SUBROUTINE PATH(TH,TL,TU,X, YI, ZI)
C DESCRIPTION:
C COMPUTES THE POSITION OF THE STREAMLINE THAT PASSES THROUGH THE
C POINT AT (-INFINITY, YI,ZI) FOR ANY X ASSUMING A GAUSSIAN HILL
C FUNCTION H(a,b)=HH*EXP(-(a/AH)**2-(b/BH)**2) . LOCAL DEFORMATION
C FACTORS Th,Tl,Tu ARE COMPUTED AT (X,Y,Z).
C NOTE THAT THE X-AXIS IS ALIGNED WITH THE INCIDENT FLOW.
C
C ARGUMENTS :
C PASSED:
C X REAL DISTANCE ALONG FLOW AT WHICH STREAMLINE COORD.
C ARE FOUND (M)
C YI.ZI REAL STREAMLINE COORD. FAR FROM HILL (M)
C RETURNED:
C TH,TL,TU REAL LOCAL DEFORMATION OR STRAIN FACTORS
C
C I/O: NONE
C
C CALLING ROUTINES: LIFTIN
C
C EXTERNALS ROUTINES: FLOW HILHGT
C
C INTRINSIC FUNCTIONS: ABS SIGN
C
C INCLUDE FILESL PARAMS.INC
C
C COMMON BLOCKS: CONST PARAMS PASL VARS
C
C
INCLUDE 'PARAMS.INC'
INCLUDE ' PARAMS. CMN'
INCLUDE 'CONST. CMN1
INCLUDE 'PASL. CMN'
INCLUDE 'VARS. CMN'
C
DATA CRIT/0.005/
DSMALL-.01*HH
YSTEP-0.5*LY
ZSTEP-0.5*HH
C *** SET INITIAL GUESSES FOR Y AND Z
Y1-1.5*YI
Z1-.75*ZI
Y2-1.01*YI
Z2-.3*ZI
IF(YI .EQ. 0.) Y2-DSMALL
IF(ZI .EQ. 0.) Z2-DSMALL
C *** COMPUTE THE STREAMLINE DEFLECTIONS FOR THE FIRST GUESSES
C ETA IS THE VERTICAL DEFLECTION, DEL IS THE LATERAL DEFLECTION
C HI IS ELEVATION OF SURFACE BENEATH THE FIRST-GUESS POSITION
C H2 IS ELEVATION OF SURFACE BENEATH THE SECOND-GUESS POSITION
CALL FLOW (X,Y1,Z1,ETA1, DELI, THI,TLI,TU)
H1-HH*HILHGT(X,Y1)
CALL FLOW(X,Y2,Z2,ETA2,DEL2,THI,TLI,TU)
H2-HH*HILHGT(X,Y2)
NITER-0
MXITER - 500
FRSAVE - FR
PTH00010
• PTH00020
PTH00030
PTH00040
PTH00050
PTH00060
PTH00070
PTH00080
PTH00090
PTH00100
PTH00110
PTH00120
PTH00130
PTH00140
PTH00150
PTH00160
PTH00170
PTH00180
PTH00190
PTH00200
PTH00210
PTH00220
PTH00230
PTH00240
PTH00250
PTH00260
PTH00270
PTH00280
PTH00290
Dfwnmnn
sri II w I i J \J w
PTH00310
PTH00320
PTH00330
PTH00340-
PTH00350
PTH00360
PTH00370
PTH00380
PTH00390
PTH00400
PTH00410
PTH00420
PTH00430
PTH00440
PTHOCI450
PTH00460
PTH00470
PTH00480
PTH00490
PTH00500
PTH00510
PTH00520
PTH00530
PTH00540
PTH00550
PTH00560
PTH00570
PTH00580
PTH00590
PTH00600
84
-------
FRINCR
0.5 * FR
C
C ***
C ***
C
10
c ***
C
c
c
c
ITERATE UNTIL THE STREAMLINE IS FOUND TO WITHIN CRIT * HH
NEW GUESS
DENY-Y1-Y2+DEL2-DEL1
IF(DENY .EQ. 0.) THEN
Y3=Y2
ELSE
Y3-(Y1*(YI+DEL2)~Y2*(YI+DEL1))/DENY
RESTRICT RATE OF CHANGE OF POSITION ESTIMATE
STEP-Y3-Y2
IF(ABS(STEP) .GT. YSTEP) Y3-Y2+SIGN(YSTEP,STEP)
ENDIF
DENZ-Z1+H1-ETA1+ETA2-Z2-H2
IF(DENZ .EQ. 0.) THEN
23-Z2
KLSE)
Z3-(Z1*(ZI+ETA2-H2)-Z2*(ZI+ETA1-H1))/DENZ
C *** RESTRICT RATE OF CHANGE OF POSITION ESTIMATE
STEP-Z3-Z2
IF(ABS(STEP) .GT. ZSTEP) Z3-Z2+SIGN(ZSTEP,STEP)
ENDIF
NITER-NITER*1
IF ITERATION DOES NOT CONVERGE, ADJUST FR UPWARD IN STEPS
UNTIL CONVERGE OCCURS
IF(NITER .GT. MXITER) THEN
FR - FR + FRINCR
IF(FR .GT. 10.0) THEN
STOP 'ENDLESS LOOP IN PATH'
ENDIF
MXITER - 100
NITER - 0
ENDIF
C COMPUTE QUANTITIES NOW FOR THE NEW GUESS.
CALL FLOWfX.YS.ZSfETAa.DEUfTHIjTLIjTU)
H3-HH*HILHGT(X,Y3)
C *** COMPUTE THE ERROR IN THE SOLUTION SCALED BY HH
ERRY-ABS((Y3-DEL3-YI)/LY)
ERRZ-ABS((Z3+H3-ETA3-ZI)/HH)
QUIT IF ERROR CRITERIA SATISFIED.
IF(ERRY .LT. CRIT .AND. ERRZ .LT. CRIT) GO TO 50
Y1-Y2
Z1-Z2
H1-H2
ETA1-ETA2
DEL1-DEL2
Y2-Y3
Z2-Z3
H2-H3
ETA2-ETA3
DEL2-DEL3
GO TO 10
50 CONTINUE
FR - FRSAVE
C
C ***
PTH00610
PTH00620
PTH00630
PTH00640
PTH00650
PTH00660
PTH00670
PTH00680
PTH00690
PTH00700
PTH00710
PTH00720
PTH00730
PTH00740
PTH00750
PTH00760
PTH00770
PTH00780
PTH00790
PTH00800
PTH00810
PTH00820
PTH00830
PTH00840
PTH00850
PTH00860
PTH00870
PTH00880
PTH00890
PTH00900
PTH00910
PTH00920
PTH00930
PTH00940-
PTH00950
PTH00960
PTH00970
PTH00980
PTH00990
PTH01000
PTH01010
PTH01020
PTH01030
PTH01040
PTH01050
PTH01060
PTH01070
PTH01080
PTH01090
PTH01100
PTH01110
PTH01120
PTH01130
PTH01140
PTH01150
PTH01160
PTH01170
PTH01180
PTH01190
PTH01200
85
-------
C *** COMPUTE T-FACTORS: IN MOST CASES, TL IS A RESIDUAL PTHCI1210
C PTH01220
TH-l./THI PTH01230
TL=THI/TU PTH01240
C PTH01250
C IF A LONG RIDGE, CONSIDER CALCULATED VALUE OF TL. IF ASPECT RATIOPTH01260
C IS 3 OR LESS, KEEP TL AS A RESIDUAL. IF ASPECT RATIO EXCEEDS 3, PTH01270
C USE A COMBINATION OF RESIDUAL VALUE AND CALCULATED VALUE AS A PTH01280
C FUNCTION OF ASPECT RATIO PTH01290
C PTH01300
ASPECT - LY/LX PTH01310
IF(ASPECT.GT.3.0 .AND. ABS(1.0 - TLI) .LT. 0.1) THEN PTH01320
TLRES - TL PTH01330
TLCALC = 1.0/TLI PTH01340
WEIGHT » ((ASPECT - 3.0)/ASPECT) ** 0.25 PTH01350
TL *• TLCALC * WEIGHT + TLRES * (1.0 - WEIGHT) PTH01360
TU - THI/TL PTH01370
ENDIF PTH01380
RETURN PTH01390
END PTH01400
86
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
SUBROUTINE PICK4(X1, X2 , X3 , X4 , XMIN, IFLAG)
SUBROUTINE: PICK4
PURPOSE: THIS ROUTINE RETURNS THE SMALLEST OF THREE NUMBERS AND A
FLAG INDICATING WHICH NUMBER WAS CHOSEN.
LIMITATIONS : IE. TWO OR MORE OF THE NUMBERS ARE EQUAL THEN THE FIRST
NUMBER IN ORDER IS RETURNED.
ARGUMENTS
PASSED:
XI REAL THE FIRST OF THE FOUR NUMBERS TO BE EXAMINED
X2 REAL THE SECOND OF THE FOUR NUMBERS TO BE EXAMINED
X3 REAL THE THIRD OF THE FOUR NUMBERS TO BE EXAMINED
X4 REAL THE FOURTH OF THE FOUR NUMBERS TO BE EXAMINED
RETURNED:
XMIN REAL THE MINIMUM OF XI, X2 , X3 , X4
IFLAG INT FLAG INDICATING WHICH NUMBER WAS CHOSEN
CALLING ROUTINES: SRISE URISE
REAL " XI, X2, X3, X4 , XMIN, X(4)
INTEGER IFLAG
X(l) - XI
X(2) - X2
X(3) - X3
X(4) - X4
XMIN - 999999.
DO 1000 1-1,4
IF(X(I) .LT.XMIN) THEN
XMIN - X(I)
IFLAG - I
ENDIF
1000 CONTINUE
C
RETURN
END
PK400010
PK400030
PK400040
PK400050
PK400060
PK400070
PK4000SO
PK400090
PK400100
PK400110
PK400120
PK400130
PK40014C
PK400150
PK400160
PK400170
PK400180
PK400190
PK400200
PK400210
PK400220
n v A rt rt o *i rt
-PK400230
PK400240
PK400250
PK400260
PK400270
PK400280
PK400290
PK400300
PK400310
PK400320
PK400330
PK400340-
PK400350
PK400360
PK400370
PK400380
PK400390
PK400400
PK400410
87
-------
SUBROUTINE PLAVG(Z, UAVG, WDAVG, DTHDZA)
C PURPOSE: THIS ROUTINE COMPUTES AVERAGE VALUES OF WIND SPEED, WIND
C DIRECTION AND POTENTIAL TEMPERATURE LAPSE RATE IN THE
C PLUME RISE LAYER.
C
C ARGUMENTS:
C PASSED:
C Z REAL HEIGHT AT WHICH INFORMATION IS DESIRED (M)
C
C RETURNED:
C UAVG REAL WIND SPEED AT HEIGHT Z, M/SEC
C WDAVG REAL WIND DIRECTION AT HEIGHT Z, DEG
C DTHDZA REAL POTENTIAL TEMPERATURE L*PSE RATE AT HEIGHT Z,
C DEG K PER METER
C
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES:
C GETWS FUNCTION WHICH RETURNS THE WIND SPEED AT HEIGHT Z
C GETWD FUNCTION WHICH RETURNS THE WIND DIRECTION AT HEIGHT Z
C GETDTH FUNCTION WHICH RETURNS DTHETA/DZ AT HEIGHT Z
C
C INTRINSIC FUCTIONS:
C
C INCLUDE FILES:
C
C COMMON: STACK
C
C
INCLUDE ' STACK. CMN'
C
REAL Z, UAVG, WDAVG, DTHDZA
C
C CALCULATE WIND SPEED AT HEIGHT Z
UAVG - GETWS (Z)
C
C CALCULATE WIND DIRECTION AT HEIGHT Z
WDAVG - GETWD(Z)
C
C CALCULATE VPTG AT HEIGHT Z
DTHDZA - GETDTH (Z)
C
RETURN
END
PLA00010
PLA00030
PLA00040
PLA00050
PLA00060
PLA (30070
PLA00080
PLA00090
PLA00100
PLACI0110
PLA00120
PLA00130
PLA00140
PLA00150
PLA00160
PLA00170
PLA00180
PLA00190
PLA00200
PLA00210
PLA00220
PLA00230
PLA00240
PLA00250
PLA00260
PLA00270
PLA00280
PLA00290
PLA00300
PLA00310
PLA00330
PLA0034«-
PLA00350
PLA00360
PLA00370
PLA00380
PLA00390
PLA00400
PLA00410
PLA00420
PLA00430
PLA00440
PLA00450
PLA00460
PLA00470
PLA00480
88
-------
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
SUBROUTINE PSRCE(SND, CSD, IZZ, Y, XP)
PURPOSE: THIS ROUTINE COMPUTES DOWNWIND AND CROSSWIND DISTANCES TO
A RECEPTOR FROM THE PLUME AXIS
ARGUMENTS
PASSED:
SND REAL SINE OF WIND DIRECTION ANGLE (DEC. FROM N)
CSD REAL COSINE OF WIND DIRECTION ANGLE
RETURNED:
IZZ INT - 1 IF AN UPWIND RECEPTOR, OTHERWISE 0
Y REAL CROSSWIND DISTANCE FROM PLUME AXIS, M
XP REAL DOWNWIND DISTANCE FROM SOURCE ALONG PLUME
TRAJECTORY, M
I/O: NONE
EXTERNAL ROUTINES: NONE
CALLING ROUTINES: SEQMOD
INTRINSIC FUNCTIONS: SQRT
COMMON BLOCKS: PASVAL
INCLUDE 'PASVAL.CMN'
REAL SND, CSD,
1 Y, XP
INTEGER IZZ
INTEGER NO, YES
DATA NO/0/
DATA YES/ I/
XI - (XS-XR)
Yl - (YS-YR)
XP - DOWNWIND DISTANCE ALONG PLUME PATH TO RECEPTOR
Y - DISTANCE PERPENDICULAR TO PLUME CENTERLINE TO RECEPTOR
XP - Y1*CSD + X1*SND
Y - X1*CSD - Y1*SND
IF IZZ - YES, RECEPTOR IS UPWIND
IF( XP .LE. 0.) THEN
IZZ - YES
ELSE
IF( XP .LT. 10.) XP - 10.
IZZ - NO
ENDIF
RETURN
END
PSR00010
PSR00030
PSR00040
PSR00050
PSR00060
PSR00070
PSR00080
PSR00090
PSR00100
PSR00110
PSR00120
PSR00130
PSR00140
PSR00150
PSR00160
PSR00170
PSR00180
PSR00190
PSR00200
PSR00210
PSR00220
PSR00230
PSR00240
PSR00250
PSR00270
PSR00280
PSR00290
PSR00300
PSR00310
PSR00320
PSR00330
PSR00340-
PSR00350
PSR00360
PSR00370
PSR00380
PSR00390
PSR00400
PSR00410
PSR00420
PSR00430
PSR00440
PSR00450
PSR00460
PSR00470
PSR00480
PSR00490
PSR00500
PSR00510
PSR00520
PSR00530
PSROOS40
PSR00550
PSR00560
PSR00570
89
-------
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
1C
SUBROUTINE RDSFC(EOR)
PURPOSE: THIS ROUTINE READS THE CURRENT HOUR'S SURFACE DATA
ARGUMENTS
PASSED: NONE
RETURNED:
EOR INT END OF FILE INDICATOR 0-NO, 1-YES
I/O:
INPUT UNIT-INSFC FILE 'SURFACE1
CALLING ROUTINES: SEQMOD
EXTERNAL ROUTINES: NONE
INTRINSIC FUNCTIONS: NONE
COMMON BLOCKS: IO PARAMS SFCMET TIME
INCLUDE 'IO.CMN1
INCLUDE ' PARAMS. CMN1
INCLUDE 'SFCMET. CMN'
INCLUDE 'TIME. CMN'
INTEGER EOR, NO, YES
DATA NO/0/, YES/ I/
READ SURFACE DATA FOR CURRENT HOUR
READ(INSFC,*,END-100) KYR,KMO,KDY,KJCD,KHR,XMH1,XMH2,
2 USTARO,EL,ZO
SET MIXING HEIGHT FROM FLAG
IF(IMIX .EQ. 0 .OR. XMH1 .LE. 0.0) THEN
XMH - XMH2
ELSE
XMH - XMH1
ENDIF
IF(XMH.LT.O.O) XMH * 99999.
COMPUTE WSTAR FOR THIS HOUR
IF (EL .GT. 0.0) THEN
STABLE
WSTAR -0.0
ELSE
UNSTABLE
WSTAR - USTARO*(XMH/(-0.4*EL))**0. 33333
ENDIF
EOR - NO
RETURN
10 EOR - YES
JCD - 99999
RETURN
END
RDS00010
RDS00030
RDS00040
RDS00050
RDS00060
RDS00070
RDS00080
RDS00090
RDS00100
RDS00110
RDS00120
RDS00130
RDS00140
RDS00150
RDS00160
RDS00170
RDS00180
RDS00190
RDS00210
RDS00220
RDS00230
RDS00240
RDS00250
RDS00260
RDS00270
ROSOCI280
RDSOCI290
RDS00300
RDS00310
RDS00320
RDS00330
RDS00340-
RDS00350
RDS00360
RDS00370
RDS00380
RDS00390
RDS00400
RDS00410
RDS00420
RDS00430
RDS00440
RDS00450
RDS00460
RDS00470
RDS00480
RDS00490
RDS00500
RDS00510
RDS00520
RDS00530
RDS00540
RDS00550
RDS00560
ff
90
-------
SUBROUTINE SEQMOD
C PURPOSE: THIS IS THE MAIN SUBROUTINE OF CTDM. PROGRAM LOOPS IN TIME,
C IN STACKS, IN HILLS AND IN RECEPTORS OCCUR HERE.
C CONCENTRATIONS ARE CALCULATED IN THIS ROUTINE.
C
C ASSUMPTIONS: FOR HOURS WITH MISSING METEOROLOGICAL DATA,
SEQ00010
SEQ00030
SEQ00040
SEQ00050
SEQ00060
SEQ00070
C CONCENTRATIONS ARE SET TO -999 FOR ALL RECEPTORS FOR THESEQ00080
C HOUR. ALSO, IF ANY PLUME IS IN AN UNSTABLE LAYER, THE
C CONCENTRATIONS ARE SET TO -999 FOR THE HOUR.
C
C I/O:
C INPUT :
C UNIT=INSFC FILE=SURFACE
C UNIT=INPROF FILE=PROFILE
C UNIT=INEMIS FILE=EMISSIONS
C UNIT=INREC FILE=RECEPTOR
C
C OUTPUT :
C UNIT=IOUT FILE=LIST
C UNIT=IOCONC FILE=CONCENTRATIONS
C
C BINARY CONCENTRATION FILE FORMAT IS:
C 4 INTEGER*2 (8 BYTES) + NRECPT REAL*4 CONCENTRATIONS PER RECORD
C THE VALUES OF THE INTEGER HEADER VARIABLES ARE:
C (1) - 2-DIGIT YEAR
C (2) - JULIAN CALENDER DAY
C (3) - HOUR (1-24)
C (4) - NUMBER OF THE RECEPTOR WITH THE HIGHEST HOURLY CONC.
C
C
C COMMON BLOCKS: (ALL COMMON BLOCKS FOUND ANYWHERE IN CTDM ARE USED
C HERE, WITH DESCRIPTIONS OF VARIABLES)
C
C
C CONST HEAD HILL IO PARAMS PASL PASW PASVAL
C PROFIL RECEPT SFCMET STACK STACKS TIME TOWER VARS
C
C
C CALLING ROUTINES:
C CTDM (MAIN)
C
C
PARAMETER ( CHIPRT-0 . 005 )
C
INCLUDE 'PARAMS. INC1
INCLUDE ' CONST. CMN1
INCLUDE 'HEAD. CMN1
INCLUDE 'HILL. CMN'
INCLUDE '10. CMN'
INCLUDE 'PARAMS. CMN1
INCLUDE 'PASL. CMN'
INCLUDE 'PASW. CMN'
INCLUDE 'PASVAL. CMN'
INCLUDE 'PROFIL. CMN1
INCLUDE 'RECEPT. CMN'
INCLUDE 'SFCMET. CMN'
INCLUDE 'STACK. CMN1
INCLUDE 'STACKS. CMN1
SEQ00090
SEQ00100
SEQ00110
SEQ00120
SEQ00130
SEQ00140
SEQ00150
SEQ00160
SEQ00170
SEQ00180
SEQ00190
SEQ00200
SEQ00210
SEQ00220
SEQ00230
SEQ00240
SEQ00250
SEQ00260
SEQ00270
SEQ00280
SEQ00290
SEQ00300
SEQ00310
SEQ00320
SEQ00330
SEQ0034«-
SEQ00350
SEQ00360
SEQ00370
SEQ00380
SEQ00390
SEQ00400
SEQ00410
SEQ00420
-SEQ00430
SEQ00440
SEQ00450
SEQ00460
SEQ00470
SEQ00480
SEQ00490
SEQ00500
SEQ00510
SEQ00520
SEQ00530
SEQ00540
SEQ00550
SEQ00560
SEQ00570
SEQ00580
SEQ00590
SEQ00600
91
-------
INCLUDE 'TIME.CMN1
INCLUDE ' TOWER. CMN '
INCLUDE 'VARS.CMN1
C
C
C
C
C
C
C
C
C
100
C
C
C
C»
~"~
C
C
C
$
$
$
$
$
$
$
$
$
$
$
$
$
$
t*TD
W.K
DEFINE LOCAL VARIABLES (THESE ARE EXPLAINED AS THEY APPEAR
IN THE CODE)
REAL BASEHL, BASEHW, BETEST, BSTKTP, CHIMAX,
CONC (MAXREC) , COSELW, COSFLO, CSD,
DELH, DELT, DTK,
DUMY, DUMZ, DX, DY, EPS, FRHI LL( MAXREC ),
HCH I LL( MAXREC ), HTOPS , HTWRAP,
PHIR, QS, RMU, RNU, ROTELW, ROTFLO,
RSHL, S, SIGRAD, SIGTH(MAXLEV) , SINELW, SINFLO,
SMUW, SND, SNUW, SPREAD, SQGAMA, SYS, TLIFT,
TMUW, TNUW, TWRAP, UCGAMA,
X, XHILLL, XHILLW, XR, XRMAJ, XS ,
XSEL, XSEW, XSMAJW, XSZS, XTEW, XTMAJW, Y, YHILLL,
YHILLW, YR, YRMAJ, YS, YSEL, YSEW, YSMAJW,
YTEW, YTMAJW, ZG
INTEGER EOF, IEND, IFLAG, IRISE, IUPW ( MAXREC ), JDY , JHR,
JMO, JYR, KHI LL( MAXREC ), KLOW, KST, NH, NHL, NO,
NRMAX, NS, YES, WDGOOD, WSGOOD, SVGOOD, SWGOOD
INTEGER* 2 MET(4)
CHARACTER*! GSGS(2)
DATA NO/0/, YES/ I/
DATA GSGS/'G1 , 'S'/
DTOR - 0.01745329
PI - 3.1415926
PIBY2 - 0.5 * PI
TWOPI - PI + PI
SQRPI - SQRT(PI)
SQR2PI - SQRT( TWOPI)
SQR2 - SQRT(2.0)
ALPHA - 1.155
UCGAMA » 0.36
SQGAMA - 0.27
SMALL - 0.00001
SVMIN =0.20
IHROUT-0
CONTINUE
READ A LINE FROM THE 'SURFACE' FILE
CALL RDSFC(EOF)
CHECK FOR END-OF-FILE
IF(EOF .EQ. YES) GO TO 999
TT*T7 ATTff OA V MTTMm?D Trt OrtWCrtT V __,•••_
X 1£« UU 1 UAX rlUfloiltK 1U UUNoULtC* -.————
IHROUT=IHROUT+ 1
IF(IHROUT/24*24 .EQ. IHROUT) WRITE(0, 9500) IHROUT/24
COMPUTE DATE/TIME DEPENDENT VARIABLES
CALL SUN ( KJCD , TZONE , ALAT , ALONG , TSR , TSS )
IF(ICASE .EQ. YES) CALL PAGE (YES)
TA - -999.
SEQ00610
SEQ0062Q
SEQ00630
SEQ00640
SEQ00650
SEQ00660
SEQ00670
SEQ00680
SEQ00690
SEQ00700
SEQ00710
SEQ00720
SEQ00730
SEQ00740
SEQ00750
SEQ00760
SEQ00770
SEQ00780
SEQ00790
SEQ00800
SEQ00810
SEQ00820
SEQ00830
SEQ00840
SEQ00850
SEQ00860
SEQ00870
SEQ00880
SEQ00890
SEQ00900
SEQ00910
SEQ00920
SEQ00930
SEQ0094fl_
SEQ00950
SEQ00960
SEQ00970
SEQ00980
SEQ00990
SEQ01000
SEQ01010
SEQO 3.020
SEQOL040
SEQ01050
SEQO 1060
SEQ01070
SEQOL080
SEQ01090
SEQ01100
SEQ01110
SEQ01130
SEQ01140
SEQ01150
SEQ01160
SEQ01170
SEQ01.130
SEQ01190
SEQ01200
92
-------
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
READ FILE 'PROFILE'
INITIALIZE FLAGS FOR AVAILABILITY OF MET VARIABLES FOR THIS
WDGOOD = NO
WSGOOD = NO
SVGOOD = NO
SWGOOD = NO
7
SECTION FOR READING AND PROCESSING "PROFILE"
-
DO 120 NHT = l.MAXLEV
SEE TABLE 5 IN CTDM USER'S GUIDE
READ(INPROF, *) JYR, JMO, JOY, JHR,HT (NHT) , IEND,
WDHR(NHT) ,WSHR(NHT) ,TAHR(NHT) ,
SIGTH(NHT) ,SWHR(NHT) ,UVHR(NHT)
HEIGHT NOW REFERENCED TO STACK BASE ELEVATION NOT TOWER
HT(NHT) - HT(NHT) + BASEHT
IF(TA.LT.O.O .AND. TAHR(NHT) . GT. 0. 0) TA - TAHR(NHT)
CHECK FOR ALL MISSING WIND SPEED AND DIRECTION
IF(WDHR(NHT) .GE. 0.0) WDGOOD » YES
IF(WSHR(NHT) .GT. 0.0) WSGOOD - YES
IF(SWHR(NHT) .GE. 0.0) SWGOOD - YES
USE YAMARTINO (1984) TO OBTAIN SIGV, UV (IF NECESSARY)
IF(ISIGV .EQ. 0) THEN
HERE, SIGMA-THETA IS PROVIDED (ISIGV - 0)
IF(SIGTH(NHT) .LE.0.0 .OR. WSHR(NHT) . LE. 0 . 0) THEN
SVHR(NHT). - -999.9
IF (UVHR(NHT) .LE.0.0) UVHR(NHT) - -999.9
ELSE
SIGRAD - SIGTH(NHT) * DTOR
EPS - SIN(SIGRAD * (1.0 - 0. 073864*SIGRAD) )
IF (UVHR (NHT) .LE.0.0) UVHR(NHT) - WSHR(NHT) *
SQRT.(1.0 - EPS*EPS)
SVHR(NHT) - SIGRAD * UVHR (NHT)
SVGOOD - YES
ENDIF
ELSE
HERE, SIGMA-V IS PROVIDED (ISIGV - 1)
IF(SIGTH(NHT) .LT. 0.0) SIGTH(NHT) - -999.9
SVHR(NHT) - SIGTH(NHT)
IF(UVHR(NHT) .LE. 0.0 .AND. WSHR(NHT) .GT. 0.0
SEQ01210
SEQ01220
HOURSEQ01230
SEQ01240
SEQ01250
SEQ01260
SEQ01270
SEQ01280
SEQ01290
SEQ01300
SEQ01310
SEQ01320
SEQ01330
SEQ01340
SEQ01350
SEQ01360
SEQ01370
SEQ01380
SEQ01390
SEQ01400
SEQ01410
SEQ01420
SEQ01430
SEQ01440
SEQ01450
SEQ01460
SEQ01470
SEQ01480
SEQ01490
SEQ01500
SEQ01510
SEQ01520
SEQ01530
SEQ0154H_
SEQ01550
SEQ01560
SEQ01570
SEQ01580
SEQ01590
- SEQ01600
SEQ01610
SEQ01620
SEQ01630
SEQ01640
SEQ01650
SEQ01660
SEQ01670
SEQ01680
SEQ01690
SEQ01700
SEQ01710
.AND. SVHR(NHT) .GE. 0.0) THEN SEQ01720
SIGRAD - SVHR(NHT) / WSHR(NHT)
STORE SIGMA-THETA VALUES IN DEGREES (SIGMA-THETA
CANNOT EXCEED 103.9 DEGREES)
SIGTH(NHT) - AMAX1(103.9, SIGRAD/DTOR)
EPS - SIN(SIGRAD * (1.0 - 0. 073864*SIGRAD) )
SEQ01730
SEQ01740
SEQ01750
SEQ01760
SEQ01770
SEQ01780
SEQ01790
SEQ01800
93
-------
C
C
C
C
UVHR(NHT) = WSHR(NHT) * SQRT ( 1 . 0-EPS*EPS)
ELSE
IF(UVHR(NHT) .LE. 0.0) UVHR(NHT) = -999.9
ENDIF
IF(SVHR(NHT) .GT. 0.0) SVGOOD = YES
ENDIF
CHECK FOR SCALAR WIND SPEED LESS THAN 1 M/SEC, RATIO SCALAR,
VECTOR SPEEDS AND SIGW, SIGV UPWARD IF NECESSARY
"
IF(WSHR(NHT) .GT. 0.0 .AND. UVHR(NHT) .GT. WSHR(NHT) )
UVHR(NHT) - WSHR(NHT)
IF( IWS1 .EQ. YES ) THEN
IF( WSHR(NHT) .LT. 1.0 ) THEN
IF( WSHR(NHT) .GT. 0.0 ) THEN
WSRT = 1.0/WSHR(NHT)
WSHR(NHT) - 1.0
IF(UVHR(NHT) .GT
IF(SVHR(NHT) .GT
IF(SWHR(NHT) .GT
ENDIF
ENDIF
ENDIF
0.0) UVHR(NHT) -UVHR(NHT) *WSRT
0.0) SVHR(NHT) -SVHR(NHT) *WSRT
0.0) SWHR(NHT) =SWHR(NHT) *WSRT
C
C
C
C
C
C
C
C
C
120
C
C
C
IN STABLE CONDITIONS, A VALUE OF SIGMA-V BELOW 0.2 M/S IS
SET TO 0.2 M/S, WHETHER OBSERVED OR CALCULATED FROM SIGMA-THETA
AND WIND SPEED
IF(SVHR(NHT) .GE. 0.0) THEN
IF(EL .GT. 0.0 .OR. HT(NHT) .GT. XMH) SVHR(NHT) =
AMAX1(SVHR(NHT) , SVMIN)
ENDIF .
CHECK FOR ERRORS IN INPUT: DATE/TIME INCONSISTENCIES,
NEGATIVE HEIGHTS OR HEIGHTS NOT MONOTONICALLY INCREASING
-
IF(JYR.NE.KYR .OR. JMO.NE.KMO .OR. JDY.NE.KDY .OR.
JHR.NE.KHR) THEN
WRITE (IOUT, 6105) JMO, JDY, JYR/JHR, KMO,KDY, KYR, KHR
STOP .
ENDIF
IF(HT(NHT) .LT. 0.0) THEN '
WRITE(IOUT,6107) JMO , JDY , JYR , JHR
WRITE (IOUT, 6 108) NHT, (HT(NHT) -BASEHT)
STOP
ENDIF
IF(NHT .GT. 1) THEN
IF( HT(NHT) .LT. HT(NHT-l)) THEN
WRITE (IOUT ,6 107) JMO, JDY, JYR, JHR
WRITE(IOUT,6109) NHT, (HT(NHT-l) -BASEHT) ,
(HT (NHT) -BASEHT)
STOP
ENDIF
ENDIF .
CHECK FOR LAST PROFILE RECORD
IF( IEND .EQ. YES ) GO TO 130
CONTINUE
END SECTION FOR PROCESSING "PROFILE" DATA
SEQ01310
SEQ01820
SEQ01830
SEQ01840
SEQ01850
SEQ01860
SEQ01870
SEQ01880
SEQ01890
SEQ01900
SEQ01910
SEQ01920
SEQ01930
SEQ01940
SEQ01950
SEQ01960
SEQ01970
SEQ01980
SEQ01990
SEQ02000
SEQ02010
SEQ02020
SEQ02030
SEQ02040
SEQ02050
SEQ02060
SEQ02070
SEQ02080
SEQ02090
SEQ02100
SEQ02110
SEQ02120
SEQ02130
SEQ02140
SEQ0215tT
SEQ02160
SEQ02170
SEQ02180
SEQ02190
SEQ02200
SEQ02210
SEQ02220
SEQ02230
SEQ02240
SEQ02250
SEQ02260
SEQ02270
SEQ02280
SEQ02290
SEQ02300
SEQ02310
SEQ02320
SEQ02330
SEQ02340
SEQ02350
SEQ02360
SEQ02370
SEQ02380
SEQ02390
SEQ02400
-------
130
C
C
C
C
C
C
C
C
C
C
C
C
C
150
C
C
160
C
C
C
C
180
C
C
C
C
C
IF(TA . LT. 0.0) THEN
TA = 293.
TAHR(l) = 293.
ENDIF
TEST FOR VARIABLE EMISSION RATES
IF(IEMIS .EQ. YES) CALL INPEMS
CHECK FOR MISSING MET DATA; IF MISSING, SKIP CALCULATIONS
FOR THIS'HOUR
IF( USTARO .LT. 0.0 ) GO TO 330
IF( ZO .LT. 0.0 ) GO TO 340
IF( WSGOOD.EQ.NO .OR. WDGOOD.EQ.NO .OR. SVGOOD.EQ.NO
.OR. SWGOOD .EQ. NO ) GO TO 350
IF(ISIGV .EQ. NO) SIGV = -9.9
DETERMINE A STABILITY CATEGORY (FOR MISCELLANEOUS APPLICATIONS)
USING THE GOLDER (1972) CURVES (GIVEN L, U*)
KST - LSTAB(EL,ZO)
WRITE CASE STUDY PRINTOUT OF METEOROLOGY
IF(ICASE .EQ. YES) THEN
WRITE(IOUT,6115) KYR,KMO,KDY,KHR,XMH,TA,USTARO,EL,ZO
DO 150 I - 1,NHT
WRITE(IOUT,6120) HT(I),WDHR(I),WSHR(I),UVHR(I),TAHR(I),
SIGTH(I),SVHR(I),SWHR(I)
CONTINUE
IF(IWS1 .EQ. 1) THEN
WRITE(IOUT,6122) BASEHT
ELSE
WRITE(IOUT,6123) BASEHT
ENDIF
ENDIF
INITIALIZE & ZERO HOURLY CONCENTRATIONS
DO 160 NR»1,NRECPT
CONC(NR) - 0.0
CONTINUE
NRMAX - 0
PRELIMINARY LOOP ON HILLS: COMPUTE HCRIT AND FROUDE NUMBER
AND STORE FOR USE BELOW
DO 180 NH - 1,NHILLS
HCHILL(NH) - HCRIT(THS(NH))
FRHILL(NH) - BULKFR(THS(NH),HCHILL(NH))
IF(HCHILL(NH) .LT. 0.0) HCHILL(NH) - 0.0
LARGE FROUDE NUMBER ESSENTIALLY NUETRAL CONDITIONS
IF(FRHILL(NH) .GE. 99.99) FRHILL(NH) - 99.99
CONTINUE
START LOOP ON STACKS
DO 300 NS-1,NSTACK
SET UP STACK COMMON VARIABLES; SEE STACKS.CMN FOR DEFINITIONS
SEQ02410
SEQ02420
SEQ02430
SEQ02440
SEQ02450
SEQ02460
SEQ02470
SEQ02480
SEQ02490
SEQ02500
SEQ02510
SEQ02520
SEQ02530
SEQ02540
SEQ02550
SEQ02560
SEQ02570
SEQ02580
,SEQ02590
SEQ02600
SEQ02610
SEQ02620
SEQ02630
SEQ02640
SEQ02650
SEQ02660
SEQ02670
SEQ02680
SEQ02690
SEQ02700
SEQ02710
SEQ02720
SEQ02730
SEQ02740
SEQ0275C"
SEQ02760
SEQ02770
SEQ02780
SEQ02790
SEQ02800
SEQ02810
SEQ02820
SEQ02830
SEQ02840
SEQ02850
SEQ02860
SEQ02870
SEQ02880
SEQ02390
SEQ02900
SEQ02910
SEQ02920
SEQ02930
SEQ02940
SEQ02950
SEQ02960
SEQ02970
SEQ02980
SEQ02990
SEQ03000
95
-------
AND. QS .GT. 0.0) QS = 1.0
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
IS NOT USED IN CURRENT MODEL
QS = SOURCE(8,NS)
IF(ICHIQ .EQ. YES
XS = SOURCE(1,NS)
YS = SOURCE(2,NS)
ZS = SOURCE(3,NS)
HS = SOURCE(4,NS)
DS = SOURCE(5,NS)
TS = SOURCE(6,NS)
VS = SOURCE(7,NS)
HB (BUILDING HEIGHT)
HB = SOURCE(9,NS)
IF(TS .LT. TA) TS = TA
DELT - (TS-TA) / TS
IF NO EMISSIONS, SKIP CALCULATIONS FOR THIS STACK
IF(QS .LE. 0.0) THEN
IF(ICASE.EQ.YES) WRITE(IOUT,6125) NS
GO TO 300
ENDIF
FB - SOURCE(10,NS) * DELT
FM COMPUTED FOR INFORMATIONAL PURPOSES ONLY
FM - SOURCE(11,NS) * TA / TS
USTKTP - GETWS(HS)
CALCULATE FINAL PLUME RISE
STABLE SECTION
IF(EL .GT. 0.0 .OR. HS .GT. XMH) THEN
IFLAG - NO
CALL SRISE(IFLAG, DELH, IRISE)
NOTE: XS2S IS DISTANCE TO WHERE TURBULENCE DOMINATES SOURCE-
INDUCED EFFECTS. FOR STABLE CONDITIONS, THIS IS ASSUMED TO BE
THE DISTANCE TO FINAL RISE; FOR NONSTABLE CONDITIONS, THIS
DISTANCE IS ASSUMED TO BE NEARLY ZERO.
IF(IRISE .LE. 9) THEN
XSZS - 0.0
ELSE
BSTKTP - SQRT((9.8/TA) * GETDTH(HS))'
XSZS - 2.07 * USTKTP/BSTKTP
ENDIF
ELSE
UNSTABLE SECTION
CALL URISE(DELH, IRISE)
XSZS - 0.0
ENDIF
COMPUTE PLUME HEIGHT
HPL - DELH +• HS
CHECK IF PLUME IS BELOW XMH IN AN UNSTABLE LAYER; IF SO, SKIP
CALCULATIONS FOR THIS HOUR.
IF(HPL .LE. XMH .AND. EL .LT. 0.0) GO TO 310
CALCULATE INITIAL SIGMAS DUE TO BUOYANCY
SEQ03010
SEQ03020
SEQ03030
SEG03040
SEQ03050
SEQ03060
SEQ03070
SEQ03080
SEQ03090
SEQ03100
SEQ03110
SEQ03120
SEQ03130
SEQ03140
SEQ03150
SEQ03160
SEQ03170
SEQ03180
SEQ03190
SEQ03200
SEQ03210
SEQ03220
SEQ03230
SEQ03240
SEQ03250
SEQ03260
SEQ03270
SEQ03280
SEQ03290
SEQ03300
SEQ03310
SEQ03320
SEQ03330
SEQ03340
SEQ03350"
SEQ03360
SEQ03370
SEQ03380
SEQ03390
SEQ03400
SEQ03410
SEQ03420
SEQ03430
SEQ03440
SEQ03450
SEQ03460
SEQ03470
SEQ03480
SEQ03490
SEQ03500
SEQ03510
SEQ03520
SEQ03530
SEQ03540
SEQ03550
SEQ03560
SEQ03570
SEQ03580
SEQ03590
SEQ03600
96
-------
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
CALL SIGB(DELH, SYS, SZS)
DETERMINE PLUME HEIGHT METEOROLOGY
GET WIND SPEED (US), WIND DIRECTION (THTA), AND VERTICAL POT.
TEMPERATURE LAPSE RATE (DTH) AT PLUME HEIGHT
CALL PLAVG(HPL, US, THTA, DTH)
CHECK IF7WIND SPEED LESS THAN 1.0 M/S AT PLUME HEIGHT
USRAT = 1.0
IF( US .LT. 1.0 ) THEN
IF( IWS1 .EQ. NO ) GO TO 370
SET RATIO TO INCREASE UV, SIGW AND SIGV
USRAT - 1.0 / US
US « 1.0
ENDIF
IF(EL .LT. 0.0) DTH - 0.0
SIGW » GETSW(HPL)*USRAT
SIGV » GETSV(HPL)*USRAT
UV - GETUV(HPL,US,SIGV)*USRAT
IF(UV .LT. USTARO) UV = USTARO
IF(UV .GT. US) UV =• US
SET MINIMA FOR SIGW, SIGV: 1% OF US
SIGW - AMAX1(SIGW,0.01*US)
SIGV - AMAX1(SIGV,0.01*US)
BRUNT - SQRT(9.8/TA * DTH)
SND - SIN(THTA*DTOR)
CSD - COS(THTA*DTOR)
CONVERT MEAN WIND DIRECTION FROM DEC CW FROM N TO DEC CCW FROM N
AND CHANGE TO FLOW DIR IN RADIANS
PHIM - (180.-THTA)*DTOR
IF(PHIM .LT. 0.0) PHIM - TWOPI -I- PHIM
ROTATE COORD. SYS. TO ALIGN ORIGINAL X-AXIS WITH THE MEAN FLOW DIR.
ROTFLO - PIBY2 + PHIM
SINFLO - SIN(ROTFLO)
COSFLO - COS(ROTFLO)
16, AND 17 IN USER'S GUIDE
CALCULATE VIRTUAL SOURCE TIME INCREMENT
TNEUT, TSTRAT, TTLZ ARE GIVEN BY EQNS 15,
TNEUT - SIGW/(UCGAMA*HPL)
TSTRAT - BRUNT/SQGAMA
TTLZ - l./(TNEUT+TSTRAT)
COMPUTE MINIMUM VIRTUAL SOURCE TIME INCREMENT: PLUME GROWTH TO
STACK DIAMETER (OR SIGMA-Y,Z GROWTH TO STACK RADIUS). IF NO
"STACK" IS USED (ZERO EXIT VELOCITY, AS WITH A TRACER), ASSUME
A DEFAULT DIAMETER OF 1 METER.
DIA - DS
IF(VS .LT. SMALL) DIA -1.0
SEE EQN 22 OF USER'S GUIDE
SEQ03610
SEQ03620
SEQ03630
SEQ03640
SEQ03650
SEQ03660
SEQ03670
SEQ03630
SEQ03690
SEQ03700
SEQ03710
SEQ03720
SEQ03730
SEQ03740
SEQ03750
SEQ03760
SEQ03770
SEQ03780
SEQ03790
SEQ03800
SEQ03810
SEQ03820
SEQ03830
SEQ03840
SEQ03850
SEQ03860
SEQ03870
SEQ03380
SEQ03890
SEQ03900
SEQ03910
SEQ03920
SEQ03930
SEQ03940-
SEQ03950
SEQ03960
SEQ03970
SEQ03980
SEQ03990
SEQ04000
SEQ04010
SEQ04020
SEQ04030
SEQ04040
SEQ04050
SEQ04060
SEQ04070
SEQ04080
SEQ04090
SEQ04100
SEQ04110
SEQ04120
SEQ04130
SEQ04140
SEQ04150
SEQ04160
SEQ04170
SEQ04180
SEQ04190
SEQ04200
97
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
220
c
c
c
c
230
ZTSTK IS VIRTUAL TIME FOR SIGMA-Z GROWTH DUE TO SOURCE EFFECTS
DUMZ = (2.0 * SIGW/DIA)**2
ZTSTK = (l.+SQRT(l.+16.*DUMZ*TTLZ**2))/(4.*DUMZ*TTLZ)
COMPUTE VIRTUAL SOURCE TIME INCREMENT, ZTV: PLUME GROWTH DUE TO
BUOYANCY (EQN 22)
IF(SZS .LE. 0.0) THEN
ZTV =0.0
ELSE
DUMZ = ~(SIGW/SZS)**2
ZTV - (l.+SQRT(l.+16.*DUMZ*TTLZ**2))/(4.*DUMZ*TTLZ)
ENDIF
ASSUME THAT TTLY IS 10000 / VECTOR WIND SPEED (AT PLUME HT).
APPLY EQN 22 FOR SIGMA-Y GROWTH SIMILAR TO THAT DONE FOR SIGMA-Z.
TTLY - 10000.0 / UV
DUMY - (2.0 * SIGV/DIA)**2
YTSTK - (l.+SQRT(l.+16.*DUMY*TTLY**2))/(4.*DUMY*TTLY)
IF(SZS .LE. 0.0) THEN
YTV - 0.0
ELSE
DUMY - (SIGV/SZS)**2
YTV - (l.+SQRT(l.-H6.*DUMY*TTLY**2))/(4.*DUMY*TTLY)
ENDIF
FINAL CALCULATION FOR VIRTUAL TIME OF TRAVEL:
A) AT A MINIMUM, IT IS THE TIME FOR PLUME GROWTH TO THE STACK
DIAMETER SIZE;
B) THE TIME FOR PLUME GROWTH DUE TO AMBIENT TURBULENCE TO THE
SIZE RESULTING FROM PLUME BUOYANCY, MINUS THE TIME FOR
TURBULENT GROWTH TO EXCEED SOURCE-INDUCE EFFECTS, IS USED IF
GREATER THAN A).
TSZS - XSZS/UV
SEE EQN 23 IN USER'S GUIDE
ZTV - AMAX1(ZTSTK,ZTV-TSZS)
YTV - AMAX1(YTSTK,YTV-TSZS)
CHECK TO SEE WHICH HILLS ARE DOWNWIND
DO 220 NH-1,NHILLS
KHILL(NH) - NO
IF ANY RECEPTOR ON A HILL IS DOWNWIND OF THE SOURCE, THEN THE
ENTIRE HILL IS CONSIDERED TO BE DOWNWIND OF THE SOURCE.
DO 230 NR - 1,NRECPT
INDEX - NRHILL(NR)
IF(INDEX .GT. 0) THEN
IF(KHILL(INDEX) .EQ. YES) GO TO 230
ENDIF
XR » RECPT(1,NR)
YR - RECPT(2,NR)
CALL PSRCE(SND,CSD,IUPW(NR),Y,X)
IF(IUPW(NR) .EQ. NO .AND. INDEX .GT. 0) KHILL(INDEX) = YES
CONTINUE
SEQ04210
SEQ04220
SEQ04230
SEQ04240
SEQ04250
SEQ04260
SEQ04270
SEQ04280
SEQ04290
SEQ04300
SEQ04310
SEQ04320
SEQ04330
SEQ04340
SEQ04350
SEQ04360
SEQ04370
SEQ04380
SEQ04390
SEQ04400
SEQ04410
SEQ04420
SEQ04430
SEQ04440
SEQ04450
SEQ04460
SEQ04470
SEQ04480
SEQ04490
SEQ04500
SEQ04510
SEQ04520
SEQ04530
SEQ04540-
SEQ04550
SEQ04560
SEQ04570
SEQ04580
SEQ04590
SEQ04600
SEQ04610
SEQ04620
SEQ04630
SEQ04640
SEQ04650
SEQ04660
SEQ04670
SEQ04680
SEQ04690
SEQ04700
SEQ04710
SEQ04720
SEQ04730
SEQ04740
SEQ04750
SEQ04760
SEQ04770
SEQ04780
SEQ04790
SEQ04800
98
-------
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
***************************************************
CASE STUDY SOURCE PRINTOUT
IF(ICASE .EQ. YES) THEN
WRITE.(IOUT,6130)
WRITE(IOUT,6135) NS , QS ,TS , VS, FB, FM, DELH
WRITE(IOUT,6140) HPL,THTA, US ,UV, SIGV, SIGW, DTK
ENDIF
START LOOP OVER HILLS AND RECEPTORS
DO 270 NHL * 0, NHILLS
IF RECEPTORS IN FLAT TERRAIN SKIP TERRAIN SECTION
IF(NHL .EQ. 0) THEN
CHECK FOR NO FLAT TERRAIN (HILL 0) RECEPTORS
IF( NRFLAT .EQ. NO ) GO TO 270
GO TO 240
ENDIF
IF ALL RECEPTORS ON HILL ARE UPWIND THEN SKIP ENTIRE LOOP
IF( KHILL(NHL) .EQ. NO ) THEN
IF(ICASE .EQ. YES) WRITE (IOUT, 6265) NHL, NS, THTA
GO TO 270
ENDIF
HC - HCHILL(NHL)
FR - FRHILL(NHL)
HTOPS - THS(NHL)
ZOHILL - 2 OH (NHL)
SECTION FOP nFFTNTNfi flFOMFTTSV FflP UP&D frtMDTTTATTnMC —____— — __ — _—_
CRITICAL HEIGHT FOR WRAP (HPL - PLUME HT ABOVE STACK BASE)
*
HTWRAP - AMIN1( HPL, HC )
GET HILL COORDS, ANGLE AND MAJOR, MINOR AXIS FOR THE WRAP
W AT END OF VARIABLE INDICATE WRAP HILL
KLOW IS THE ARRAY INDEX TO THE HEIGHT CLOSEST TO (BUT LESS
THAN) HTWRAP
KLOW - KLOSEf ZHS(1,NHL), NZH(NHL), HTWRAP )
IF( KLOW .EQ. 0 ) KLOW - 1
BASEHW - ZHS (KLOW, NHL)
IF( KLOW .EQ. NZH(NHL) ) THEN
THE CRITICAL HT IS ABOVE LAST CONTOUR VALUE
DO NOT INTERPOLATE, BUT USE INVERSE POLYNOMIAL FORMULA
GET X, Y, ORIENTATION OF THE ELLIPSE FOR WRAP FROM THE
LOOK-UP TABLE.
XHILLW - XHW( KLOW, NHL)
YHILLW - YHW( KLOW, NHL)
THTAH - MAJORW( KLOW, NHL)
DISTANCE SOURCE TO HILL CENTER
SEQ04810
SEQ04820
SEQ04330
SEQ04340
SEQ04850
SEQ04860
SEQ04870
SEQ04880
SEQ04890
SEQ04900
SEQ04910
SEQ04920
SEQ04930
SEQC494C
SEQ04960
SEQ04970
SEQ04980
SEQ04990
SEQ05000
SEQ05010
SEQ05020
SEQ05030
SEQ05040
SEQ05050
SEQ05060
SEQ05070
SEQ05080
SEQ05090
SEQ05100
SEQ05110
SEQ05120
SEQ05130
SEQ05148-
SEQ05150
SEQ05160
SEQ05170
SEQ05190
SEQ05200
SEQ05210
SEQ05220
HILLSEQ05230
SEQ05240
SEQ05250
SEQ05260
SEQ05270
SEQ05280
SEQ05290
SEQ05300
SEQ05310
SEQ05320
SEQ05330
SEQ05340
SEQ05350
SEQ05360
SEQ05370
SEQ05380
SEQ05390
SEQ05400
99
-------
DX = XS - XHILLW SEQ05410
DY = YS - YHILLW SEQ05420
RSHW = SQRT( DX*DX + DY*DY ) SEQ05430
C SEQ05440
C COMPUTE MAJOR & MINOR AXIS LENGTHS: INTERPOLATE BETWEEN SEQ05450
C MAJAXW, MINAXW AND 0.0 IF ABOVE THE LAST CONTOUR SEQ05460
C SEQ05470
FRACT = 1.0 - (HTWRAP - BASEHW)/(HTOPS - BASEHW) SEQ05430
AAXW = MAJAXW(KLOW,NHL) * FRACT SEQ05490
BAXW = MINAXW(KLOW,NHL) * FRACT SEQ05500
ELSE " SEQ05510
C LINEARLY INTERPOLATE BETWEEN TWO VALUES SEQ05520
XHILLW = XINTRP( ZHS (KLOW, NHL) , ZHS (KLOW-t-1, NHL) , HTWRAP, SEQ05530
* XHW(KLOW, NHL), XHW(KLOW-(-l, NHL) ) SEQ05540
YHILLW =» XINTRP( ZHS (KLOW, NHL) , ZHS (KLOW-t-1, NHL) , HTWRAP, SEQ05550
* YHW(KLOW,NHL), YHW(KLOW+1,NHL)) SEQ05560
AAXW - XINTRP( ZHS(KLOW,NHL), ZHS(KLOW+1,NHL), HTWRAP, SEQ05570
* MAJAXW(KLOW,NHL), MAJAXW(KLOW+1,NHL)) SEQ05580
BAXW - XINTRP( ZHS (KLOW, NHL) , ZHS (KLOW-t-1, NHL) , HTWRAP, SEQ05590
* MINAXW (KLOW,NHL) , MINAXW (KLOW-i-1, NHL) ) SEQ05600
THTAH - ANGINT( MAJAXW(KLOW,NHL),MINAXW(KLOW,NHL), SEQ05610
* MAJORW(KLOW,NHL), ZHS(KLOW,NHL), SEQ05620
* MAJAXW(KLOW+1,NHL),MINAXW(KLOW+1,NHL), SEQ05630
* MAJORW(KLOW+1,NHL), ZHS (KLOW-t-1, NHL) , SEQ05640
* HTWRAP ) SEQ05650
C SEQ05660
C CHECK THAT ELLIPSE AXES ARE LESS THAN DIST FROM SOURCE SEQ05670
C TO HILL CENTER AAX <= BAX < DIST SOURCE/HILL CENTER SEQ05680
DX - XS - XHILLW SEQ05690
DY - YS - YHILLW SEQ05700
RSHW - SQRT( DX*DX +• DY*DY ) SEQ05710
IF( AAXW .GT. RSHW ) AAXW - 0.99 * RSHW SEQ05720
IF( BAXW .GT. AAXW ) BAXW - AAXW SEQ05730
ENDIF SEQ05748-
C SEQ05750
C SHIFT ORIGIN TO CENTER OF WRAP HILL (E DENOTES ELLIPSE) SEQ05760
XSEW * XS - XHILLW SEQ05770
YSEW - YS - YHILLW SEQOS780
XTEW - XT - XHILLW SEQ05790
YTEW - YT - YHILLW ' SEQOS800
C ' • SEQOS810
C FIND TOWER AND SOURCE LOCATIONS RELATIVE TO MAJOR AXIS OF SEQ05820
C WRAP HILL ELLIPSE. NOTE: X-AXIS LIES ALONG MAJOR AXIS SEQ05830
ROTELW - (90.0 - THTAH) * DTOR SEQ05840
COSELW - COS(ROTELW) SEQ05850
SINELW - SIN(ROTELW) SEQ05860
XTMAJW - XTEW*COSELW + YTEW*SINELW SEQ05870
YTMAJW - -XTEW*SINELW + YTEW*COSELW SEQ05880
XSMAJW - XSEW*COSELW + YSEW*SINELW SEQ05890
YSMAJW - -XSEW*SINELW + YSEW*COSELW SEQ05900
C SEQ05910
C COMPUTE ELLIPTICAL COORDS OF SOURCE AND TOWER SEQ05920
CALL MUNU( XSMAJW, YSMAJW, AAXW, BAXW, SMUW, SNUW ) SEQ05930
CALL MUNU( XTMAJW, YTMAJW, AAXW, BAXW, TMUW, TNUW ) SEQ05940
C SEQ05950
C SET UP DATA FOR FLOW BELOW HC (WRAP) SEQ05960
CALL WRAPINC TMUW, TNUW, SMUW, SNUW, XSMAJW, YSMAJW ) SEQ05970
C SEQ05980
C CHECK THE WRAP/LIFT TIME RATIO (TFAC). NOTE THAT THE SEQ05990
C TIME TO LIFT USES 'SO' WHICH IS COMPUTED BY WRAPIN USING SEQ06000
100
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
.
c
c
c
THE WRAP HILL ELLIPSE VARIABLES
TFAC =0.0
TWRAP =• SOBETA / UVBETA + ZTV
TLIFT = SO / UV + ZTV
IF (TLIFT .LT. 0.0) THEN
IF(ICASE .EQ. YES) WRITE (IOUT, 6270) NHL, NS , THTA
GO TO 270
ENDIF
IF( TLIFT .NE. 0.0 ) TFAC = TWRAP/TLIFT
COMPUTE SIGMA-Z AT THE IMPINGEMENT POINT FOR LIFT TIME
SZTEST =• SIGW * TLIFT/SQRT( 1.0 + 0 . 5*TLIFT/TTLZ )
WRITE OUT HILL INFO AND WRAP VARIABLES
IF( ICASE .EQ. YES) THEN
CALL PAGE (YES)
WRITE(IOUT,6150) NHL, (HILNAM(I ,NHL) , 1=1, 10) , HC, FR
WRITE (IOUT, 615 5) RSHW, HTWRAP, AAXW, BAXW, THTAH,
1 ABS( SOBETA)
ENDIF
GET ARRAY INDEX TO CONTOUR BELOW CUT-OFF HILL
~
KLOW - KLOSE( ZHS(1,NHL), NZH(NHL) , HC )
IF( KLOW .EQ. 0 ) KLOW = 1
OBTAIN X, Y, ORIENTATION OF CUT-OFF HILL FROM LOOK-UP TABLES
FOR LIFT
XHILLL - XHL( KLOW, NHL)
YHILLL - YHL( KLOW, NHL)
THTAH - MAJORL( KLOW, NHL)
DX - XS - XHILLL
DY - YS - YHILLL
RSHL - SQRT( DX*DX + DY*DY )
CUT-OFF HILL BASE AND HEIGHT FOR LIFT
BASEHL - ZHS( KLOW, NHL)
HH - HTOPS - HC
IF(KLOW .EQ. NZH(NHL)) THEN
COMPUTE MAJOR & MINOR AXIS LENGTHS: INTERPOLATE BETWEEN
MAJAXW, MINAXW AND 0.0 IF ABOVE THE LAST CONTOUR
FRACT - 1.0 - (HC+0.5*HH - BASEHW)/ (HTOPS - BASEHW)
AAXL - MAJAXW (KLOW, NHL) * FRACT
BAXL - MINAXW (KLOW, NHL) * FRACT
ELSE
CALL TERAX( SCALMA (KLOW, NHL) , SCALMI (KLOW, NHL) ,
* EXPOMA (KLOW, NHL) , EXPOMI (KLOW, NHL) ,
* (HTOPS-BASEHL) , (HC+0. 5*HH) , BASEHL, RSHL,
* AAXL, BAXL )
ENDIF
CONVERT THTAH TO RADIANS CCW FROM N
PHIHL-- THTAH*DTOR+TWOPI
SHIFT ORIGIN TO CENTER OF LIFT HILL (E DENOTES ELLIPSE)
XSEL - XS - XHILLL
YSEL - YS - YHILLL
SEQ06010
SEQ06020
SEQ06030
SEQ06040
SEQ06050
SEQ06060
SEQ06070
SEQ06030
SEQ06090
SEQ06100
SEQ06110
SEQ06120
SEQ06130
SEQ06140
SEQ06150
SEQ06160
SEQ06170
SEQ06180
SEQ06190
SEQ06200
SEQ06210
SEQ06220
cvr\n £ *5 1 n
o&yUo^jU
SEQ06240
SEQ06250
SEQ06260
SEQ06270
SEQ06280
SEQ06290
SEQ06300
SEQ06310
SEQ06320
SEQ06330
SEQ0634Q_
SEQ06350
SEQ06360
SEQ06370
SEQ06380
SEQ06390
SEQ06400
SEQ06410
SEQ06420
SEQ06430
SEQ06440
SEQ06450
SEQ06460
SEQ06470
SEQ06480
SEQ06490
SEQ06500
SEQ06510
SEQ06520
SEQ06530
SEQ06540
SEQ06550
SEQ06560
SEQ06570
SEQ06530
SEQ06590
SEQ06600
101
-------
c
c
c
c
c
c
c
c
c
c
c
c
240
C
C
C
C
c
c
c
c
c
c
c
ROTATE COORD SYS TO ALIGN ORIGINAL X-AXIS W/ MEAN FLOW DIR
XSEPL = XSEL*COSFLO + YSEL*SINFLO
YSEPL = -XSEL*SINFLO + YSEL*COSFLO
DETERMINE SPEED SHEAR FOR FLOW; SET UP LIFT VARIABLES
Zl = HPL
Ul - US
22 = HC
IF(ABS(Z2-Z1) .LT. 0.1 * HH) 22 = HTOPS
U2 = GETWS(Z2)
DELU - U2 - Ul
IF(ABS(DELU) .LT. 0.001} DELU =0.0
DELZ =» 22 - Zl
IF(DELZ .EQ. 0.0) THEN
ALF - 0.0
ELSE
ALF - AMAX1( 0.0, DELU/ DELZ)
ENDIF
CALL LIFTIN(IFLOW)
IF(IFLOW .EQ. 1) GO TO 360
IF(FR .LT. 0.8 .AND. ICASE .EQ. YES) WRITE(IOUT, 6158)
WRITE LIFT INFORMATION
IF (ICASE .EQ. YES) THEN
WRITE (IOUT, 6160) RSHL, HC + 0.5*HH, AAXL, BAXL, THTAH,
1 ABS (XSEPL), YSEPL, SO
ENDIF
SET UP COLUMN TITLES FOR RECEPTOR CASE-STUDY OUTPUT
IF( ICASE .EQ. YES ) THEN
WRITE (IOUT, 6 170) GSGS (ICHIQ+1)
NLINES - NLINES + 5
IF (NHL .GT. 0) NLINES - NLINES + 22
ENDIF
DO 260 NR - 1, NRECPT
CHECK IF THIS RECEPTOR IS ON CURRENT HILL
IF( NRHILL(NR) .NE. NHL ) GO TO 260
SET UP RECEPTOR VARIABLES
ZELEV IS RECEPTOR HEIGHT ABOVE GROUND SURFACE
XR - RECPT(1,NR)
YR - RECPT(2,NR)
ZELEV - RECPT(3,NR)
ZG - RECPT(4,NR)
Z - ZELEV + ZG
DO NOT ALLOW RECEPTOR TO BE BELOW THE MODEL ZERO PLANE
IF( Z .LT. 0.0 ) Z =• 0.0
INITIALIZE CONCENTRATION
C - 0.0
SEQ06610
SEQ06620
SEQ06630
SEQ06640
SEQ06650
SEQ06660
SEQ06670
SEQ06680
SEQ06690
SEQ06700
SEQ06710
SEQ06720
SEQ06730
SEQ06740
SEQ06750
SEQ06760
SEQ06770
SEQ06780
SEQ06790
SEQ06800
SEQ06810
SEQ06820
SEQ06830
SEQ06S40
SEQ06850
SEQ06860
SEQ06870
SEQ06880
SEQ06890
SEQ06900
SEQ06910
SEQ06920
SEQ06930
SEQ0594«-
SEQ06950
SEQ06960
SEQ06970
SEQ06980
SEQ06990
SEQ07000
SEQ07020
SEQ07030
SEQ07040
SEQ07050
SEQ07060
SEQ07070
SEQ07080
SEQ07090
SEQ07100
SEQ07110
SEQ07120
SEQ07130
SEQ07140
SEQ07150
SEQ07160
SEQ07170
SEQ07180
SEQ07190
SEQ07200
102
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
IF ESSENTIALLY FLAT TERRAIN (HILL = 0), CALL FLAT AND
IF (NHL .EQ. 0) THEN
IF(IUPW(NR) .EQ. YES) GO TO 260
CALL FLAT(QS,Z)
NLINES * NLINES + 2
.GO TO 250
END-IF
START RECEPTOR COORD SETUP FOR CALL TO LIFT
SHIFT ORIGIN TO CENTER OF HILL
XEL- XR - XHILLL
Y2L- YR - YHILLL
ALIGN X-AXIS WITH MEAN FLOW
XEPL = XEL* COSFLO + YEL* SINFLO
YEPL - -XEL* SINFLO + YEL* COSFLO
CALC DIRECTION FROM SOURCE TO RECEPTOR (CCW FROM N)
PHIR - ATAN2( (XSEL-XEL) , (YEL-YSEL) )
IF( PHIR .LT. 0.0 ) PHIR - PHIR -1- TWOPI
CHECK IF TRAJECTORY IS TOWARDS RECEPTOR FOR LIFT CALC.
SPREAD - ABS( PHIR - PHIM )
IF( SPREAD .GT. PI ) SPREAD = -SPREAD + TWOPI
IF( SPREAD .GT. PIBY2) THEN
RECEPTOR IS NOT DOWNWIND
IF( ICASE .EQ. YES ) WRITE (IOUT, 8010) NR
ELSE
S - XEPL - XSEPL
USE LIFT FOR ALL RECEPTORS AT OR ABOVE HC
IF( Z .GE. HC ) THEN
CALL LIFT(QS)
ELSE
IF( ICASE .EQ. YES ) WRITE(IOUT, 6175) NR
ENDIF
ENDIF
COMPUTE RECEPTOR COORDS RELATIVE TO WRAP HILL
SEQ07210
EXITSEQ07220
SEQ07230
SEQ07240
SEQ07250
SEQ07260
SEQ07270
SEQ07280
SEQ07290
SEQ07300
SEQ07310
SEQ07320
SEQ07330
SEQ07340
SEQ07350
SEQ07360
SEQ07370
SEQ07380
SEQ07390
SEQ07400
SEQ07410
SEQ07420
SEQ07430
SEQ07440
SEQ07450
SEQ07460
SEQ07470
SEQ07480
SEQ07490
SEQ07500
SEQ07510
SEQ07520
SEQ07530
SEQ0754Q—
SEQ07550
SEQ07560
SEQ07570
SEQ07580
SEQ07590
SEQ07600
SEQ07610
SEQ07620
FIND RECEPTOR LOCATION RELATIVE TO MAJOR AXIS OF ELLIPSE SEQ07630
SHIFT ORIGIN TO CENTER OF WRAP HILL
XEW- XR - XHILLW
YEW- YR - YHILLW
XRMAJ - XEW* COSELW + YEW* SINELW
YRMAJ - -XEW* SINELW + YEW* COSELW
IS RECEPTOR ON SOURCE SIDE OF STAGNATION STREAMLINE
CALL MUNU( XRMAJ, YRMAJ, AAXW, BAXW, RMU, RNU )
IF( ABS(PSIHAT) .LE. SMALL ) THEN
SIGNYE - 1.0
ELSE
SIGNYE - SIGN (1.0, -SIN(RNU+ALPHAW) /PSIHAT)
ENDIF
CALCULATE POSITION ALONG BETA
XRBETA - XRMAJ*COS(BETA) + YRMAJ *S IN (BETA)
SEQ07640
SEQ07650
SEQ07660
SEQ07670
SEQ07680
SEQ07690
SEQ07700
SEQ07710
SEQ07720
SEQ07730
SEQ07740
SEQ07750
SEQ07760
SEQ07770
SEQ07780
SEQ07790
SEQ07800
100
103
-------
c
c
c
c
c
c
c
250
C
C
C
C
c
260
C
C
C
270
C
C
C
300
C
C FIND
C
305
C
C
C
C
C
CHECK IF TRAJECTORY IS TOWARDS RECEPTOR FOR WRAP CALC.
BETEST = XRBETA / XSBETA
IF( BETEST .GT. 1.0 ) THEN
RECEPTOR IS NOT DOWNWIND
IF( ICASE .EQ. YES ) WRITE (IOUT, 8020) NR
ELSE IF( (HC/HH) .GT. SMALL ) THEN
COMPUTE AND ADD CONCENTRATION DUE TO PLUME MATERIAL BELOW HC
' CALL WRAP(QS)
ELSE IF( ICASE .EQ. YES } THEN
- WRITE (IOUT ,6 17 8) NR
ENDIF
NLINES = NLINSS + 4
STORE HOURLY CONCENTRATION AND SCALE BY EMISSION RATE
CONC(NR) - CONC(NR) + C
CHECK IF PAGE IS FULL
IF ( ICASE. EQ. YES .AND. NLINES .GE. MAXLIN-3) THEN
CALL PAGE (YES)
WRITE (IOUT ,6170) GSGS (ICHIQ+1)
NLINES - NLINES + 5
ENDIF
CONTINUE
CONTINUE
CONTINUE
THE MAXIMUM PREDICTED CONCENTRATION
CHIMAX - 0.0
DO 305 NR - 1,NRECPT
IF(CONC(NR) .GT. CHIMAX) THEN
CHIMAX - CONC(NR)
NRMAX - NR
ENDIF
CONTINUE
PRINT HOURLY MAX CONCENTRATION
IF ( ICASE. EQ. YES) THEN
IF(CHIMAX .GT. CHIPRT) THEN
WRITE (IOUT, 6185) CHIMAX, GSGS (ICHIQ+1) , NRMAX
ELSE
WRITE (IOUT, 6190) CHIMAX, GSGS (ICHIQ+1) , NRMAX
ENDIF
ENDIF
FILL TOP N ARRAYS
IF(ITOPN .EQ. YES) CALL TOPN( CONG, NRECPT, 0, GSGS (ICHIQ+1) )
GO TO 400
SEQ07810
SEQ07820
SEQ07830
SEQ07840
SEQ07350
SEQ07860
SEQ07870
SEQ07380
SEQ07890
SEQ07900
SEQ07910
SEQ07920
SEQ07930
SEQ07940
SEQ07950
SEQ07960
SEQ07970
SEQ07980
SEQ07990
SEQ08000
SEQ08010
SEQ03020
SEQ08030
SEQ08040
SEQ08050
SEQ08060
SEQ08070
SEQ08080
SEQ08090
SEQ08100
SEQ08110
SEQ08120
SEQ08130
SEQ08140
SEQ08150
SEQ08160
SEQ08170
SEQ08180
SEQ08190
SEQ03200
SEQ08210
SEQ08220
SEQ08230
SEQ08240
SEQ08250
SEQ08260
SEQ08270
SEQ08280
SEQ08290
SEQ08300
SEQ08310
SEQ08320
SEQ08330
SEQ08340
SEQ0835Q
SEQ08360
SEQ08370
SEQ08380
SEQ08390
HOURLY ERROR SECTION FOR CASES WHEN THE MODEL IS NOT APPROPRIATESEQ08400
104
-------
c
c
c
310
315
C
C
C
330
335
C
C
C
340
345
C
C
C
350
355
C
C
C
360
365
C
C
C
370
375
C
C
C
400
C
C
PLUME IS BELOW XMH IN AN UNSTABLE LAYER
DO 315 NR=1,NRECPT
CONC(NR) = -999.
CONTINUE
IF(ICASE .EQ. YES) WRITE(IOUT,9315) JYR, JMO, JDY, KJCD, JHR
GO TO 400.
USTAR MIS,SING
DO 335 NR-1,NRECPT
CONC(NR) - -999.
CONTINUE
IF(ICASE .EQ. YES) WRITE(IOUT,9335) JYR, JMO, JDY, KJCD, JHR
GO TO 400
ZO MISSING
DO 345 NR-1,NRECPT
CONC(NR) - -999.
CONTINUE
IF(ICASE .EQ. YES) WRITE(IOUT,9345) JYR, JMO, JDY, KJCD, JHR
GO TO 400
MISSING MET DATA: EITHER WD, WS, SIGV, OR SIGW
DO 355 NR-1,NRECPT
CONC(NR) - -999.
CONTINUE
IF(ICASE .EQ. YES) WRITE(IOUT,9355) JYR, JMO, JDY, KJCD, JHR
GO TO 400
FLOW ALGORITHM BEYOND DESIGN CRITERIA
DO 365 NR-1,NRECPT
CONC(NR) - -999.
CONTINUE
WRITE(IOUT,9365) JYR, JMO, JDY, KJCD, JHR
WIND SPEED AT PLUME HEIGHT LESS THAN 1.0 M/S'
DO 375 NR-1,NRECPT
CONG(MR) - -999.
CONTINUE
IF(ICASE .EQ. YES) WRITE(IOUT,9375) JYR, JMO, JDY, KJCD, JHR
WRITE CONCENTRATIONS TO BINARY OUTPUT FILE
IF(ICONC .NE. NO) THEN
MR - NRECPT
IF( CONC(l) .EQ. -999. ) NRMAX - 0
MET(l) - JYR
MET(2) - KJCD
MET(3) - JHR
MET(4) - NRMAX
CALL WRITIT(MET,CONC,NRECPT,IOCONC)
ENDIF
END OF HOURLY LOOP
SEQ08410
SEQ08420
SEQ08430
SEQ08440
SEQ08450
SEQ08460
SEQ08470
SEQ08480
SEQ08490
SEQ08500
SEQ08510
SEQ08520
SEQ08530
SEQ08540
SEQ08550
SEQ08560
SEQ08570
SEQ08580
SEQ08590
SEQ08600
SEQ08610
SEQ08620
SEQ08630
SEQ08640
SEQ08650
SEQ08660
SEQ08670
SEQ08630
SEQ08690
SEQ08700
SEQ08710
SEQ08720
SEQ08730
SEQ0874&-
SEQ08750
SEQ08760
SEQ08770
SEQ08780
SEQ08790
SEQ08800
SEQ08810
SEQ08820
SEQ08830
SEQ08840
SEQ08850
SEQ08360
SEQ08870
SEQ08880
SEQ08890
SEQ08900
SEQ08910
SEQ08920
SEQ08930
SEQ08940
SEQ08950
SEQ08960
SEQ08970
SEQ08980
SEQ08990
SEQ09000
105
-------
c
999
C
C
6105
6107
6108
6109
6115
1
2
3
4
5
6
7
it
B
9
A
6120
6122
6123
1
2
3
4
1
2
6125
6130
6135
1
2
3
4
1
2
3
6140
6150
6155
6158
1
2
3
4
1
2
GO TO 100
CONTINUE .
PRINT TOP N TABLE (IF NECESSARY)
IF(ITOPN .EQ. YES) CALL TOPN( CONC, NRECPT, 1, GSGS (ICHIQ+1) )
RETURN
SEQ09010
SEQ09020
SEQ09030
SEQ09040
3EQ09050
SEQ09060
SEQ09070
SEQ09080
SEQ09090
SEQ09100
SEQ09110
SEQ09120
SEQ09130
SEQ09140
SEQ09150
SEQ09160
SEQ09170
SEQ09180
SEQ09190
SEQ09200
YR MO DA HR',SEQ09210
SEQ09220
SEQ09230
SEQ09240
SEQ09250
SEQ09260
SEQ09270
SEQ09280
6160
FORMAT(/,~1X, 'DISAGREEMENT IN PROFILE VS. SURFACE DATA: ',/,10X
'PROFILE DATA DATE:HOUR IS ',12,'/',12,'/',12,':',12,/,10X,
'SURFACE DATA DATE:HOUR IS ',12,'/',12,'/',12,':',12)
FORMAT(/,IX,'PROFILE HEIGHT VALUE INCORRECT: ',/,10X,
'PROFILE DATA DATE:HOUR IS ' ,12, '/' ,12, '/',12, ' : ' ,12)
FORMAT(/' LEVEL NUMBER: ',12, ' HEIGHT: ',F8.2/)
FORMAT(/' LEVEL NUMBER: ',12, ' PREVIOUS HEIGHT: ' , F8.2,
' CURRENT HEIGHT:',F8.2)
FORMAT( IX,80('-'),//,' INPUT MET DATA FROM SURFACE AND ',
' PROFILE (NOTE: ****** = MISSING DATA):1,//,
T40,'MONIN- SFC',/,T17,
'MIXING SFC SFC OBUKHOV ROUGH.',/,T17,
'HEIGHT TEMP U* LENGTH LENGTH',/,'
(M) (K) (M/S) (M) (M)',//,
IX,413,3X,F6.1,2X,F5.1,IX,F5.3,3X,F7.1,2X,F7.4,///,
T9,'ADJUSTED WIND <-WIND SPEED-> AMB. SIGMA-',/,
T10,'HEIGHT DIR. SCALAR VECTOR TEMP THETA SIGMA-V
1 SIGMA-W',/,
T10,' (M) (DEC) (M/S) (M/S) (K) (DEC) (M/S)',
(M/S)',/)
FORMAT(T10,F6.1,2X,F5.1,2X,F6.2,2X,F6.2,1X,F6.2,1X,F5.1,3X,F6.2,SEQ09290
4X,F6.2) SEQ09300
FORMAT(/,10X,'NOTE: SCALAR WIND SPEEDS USED IN CTDM ARE SET TO',SEQ09310
1 A MINIMUM OF 1 M/S'/ SEQ09320
10X,'NOTE: HEIGHTS ARE REFERENCED TO THE COMMON STACK BASE', SEQ09330
' ELEVATION',/,10X, SEQ0934O-
' THE ADJUSTMENT TO THE INPUT HEIGHT IS ',F5.1,' METERS.'/)SEQ09350
FORMAT(1OX,'NOTE: HEIGHTS ARE REFERENCED TO THE COMMON STACK ', SEQ09360
'BASE ELEVATION',/,!OX, SEQ09370
' THE ADJUSTMENT TO THE INPUT HEIGHT IS ',F5.1,' METERS.'/)SEQ09380
FORMAT(/,10X,'NO EMISSIONS FROM SOURCE # ',I2,/> SEQ09390
FORMAT{/,' < SOURCE INFORMATION > ',SEQ09400
•FINAL PLUME',/, . SEQ09410
1 SOURCE QS TS VS BUOY FLUX MOM FLUX RISE',SEQ09420
/,' # (G/S) (K) (M/S) (M4/S3) (M4/S2) ', SEQ09430
1(M)',/) SEQ09440
FORMAT(I4,F9.1,F7.1,F6.2,F9.1,F10.1,5X,F10.2, SEQ09450
//,2X,'VARIABLES AT ',T21,'HEIGHT WDIR ', SEQ09460
'USCAL UVECT SIGV SIGW DTHDZ',/,2X,'PLUME HEIGHT:', SEQ09470
T21,1 (M) (DEG) (M/S) (M/S) (M/S) (M/S) (DEG/M)',/) SEQ09480
FORMAT(' ',F7.1,F7.0,F7.2,2F7.2,2F8.4) SEQ09490
FORMAT(//,2X,'INFORMATION FOR HILL ',12,': ',10A4,//, SEQ09500
7X,'HCRIT - ',F7.1,' M; FROUDE # ABOVE HCRIT - ',F5.2) SEQ09510
FORMAT(//,5X,'WRAP INFORMATION:',/,7X,'DISTANCE FROM SOURCE TO',SEQ09520
' HILL CENTER - ',F6.1,' M; WRAP HT - ',F6.1,' M',/,7X, SEQ09530
'ELLIPSE AXIS LENGTHS: MAJOR - ',F7.1,' M; MINOR - '.F7.1, SEQ09540
1 M',/,7X,'MAJOR AXIS AZIMUTH FROM NORTH - ',F5.1,' DEG1,/, SEQ09550
7X,'DISTANCE TO PRIMARY IMPINGEMENT POINT - ',F7.1,' M',/) SEQ09560
FORMAT(/,5X,'WARNING: FROUDE NUMBER USED IN LIFT MODEL IS ', SEQ09570
'SIGNIFICANTLY BELOW',/,5X,'THE INTENDED RANGE OF ', SEQ09580
•APPLICABILITY. USE CONCENTRATIONS WITH CAUTION.',/) SEQ09590
FORMAT(/,5X,'LIFT INFORMATION:',/,7X,'DISTANCE FROM SOURCE TO', SEQ09600
/OS
106
-------
1 ' HILL CENTER = ',F6.1,' M; LIFT MIDPOINT HT = ',F6.1,/,7X, SEQ09610
2 'ELLIPSE AXIS LENGTHS: MAJOR = ',F7.1,' M;MINOR = ',F7.1,' M1, SEQ09620
3 /,7X,'MAJOR AXIS AZIMUTH FROM NORTH = ',F5.1,' DEG',/,7X, SEQ09630
4 'DISTANCE-ALONG FLOW FROM SOURCE TO HILL CENTER = ',F7.1,' M1,/,SEQ09640
5 7X,'CROSSFLOW DISTANCE FROM SOURCE TO HILL CENTER = ',F7.1,' M',SEQ09650
6 /,7X,'DISTANCE TO PRIMARY IMPINGEMENT POINT = ',F7.1,' M1,/) SEQ09660
6170 FORMAT(/,T9,'SRC-RECP SRC-RECP RECEPTOR EFF. FLAT ', SEQ09670
1 HILL-INDUCED1,/, SEQ09680
2 L ^DISTANCE DISTANCE HT ABOVE SRC-RECP TERRAIN ', SEQ09690
3 EFFECTIVE TOTAL1,/,' REC / ALONG FLOW CROSS FLOW STK ', SEQ09700
4 BASE HT TJIFF SIG-Y SIG-Z SIG-Y SIG-Z CONC',/, SEQ09710
5 # W (M) (M) (M) (M) (M) (M)1, SEQ09720
6 (M) (M) (U1,A1,'/M**3)') SEQ09730
5172 FORMAT(I3) SEQ09740
6175 FORMAT(/,IX,13,' LIFT N/A (RECEPTOR BELOW HC)') SEQ09750
6178 FORMAT(IX,13,' WRAP N/A (PLUME ABOVE HC OR UPWIND OF HILL)') SEQ09760
6130 FORMAT(IX,'NOTE: FLAT TERRAIN AND HILL-INDUCED SIGMA-Y AND-Z ', SEQ09770
1 'VALUES ARE THE SAME FOR WRAP,',/,IX,' AND WILL DIFFER FOR ', SEQ09780
2 'LIFT IF THE PLUME IS CLOSE TO THE HILL AND THE RECEPTOR.',/) SEQ09790
6185 FORMAT(/,IX,'MAXIMUM CONCENTRATION FOR THIS HOUR IS ', SEQ09800
1 F10.2,1 U',A1,'/M**3 AT RECEPTOR # ',I3,/) SEQ09810
6190 FORMAT(/,IX,'MAXIMUM CONCENTRATION FOR THIS HOUR IS ', SEQ09820
1 1PE10.4,' U',A1,'/M**3 AT RECEPTOR I ',13,/) SEQ09830
6265 FORMAT(/' ALL RECEPTORS ON HILL ',12,' ARE UPWIND OF SOURCE ', SEQ09840
* 12,' THIS HOUR. WIND DIR. IS ',F5.1,/) SEQ09850
6270 FORMAT(/' POSITION OF HILL ',12,' IS UPWIND OR FAR TO THE SIDE',SEQ09860
* ' OF THE PLUME FROM SOURCE ',I2,/,' THIS HOUR. ', SEQ09870
* ' WIND DIRECTION IS ',F5.1,/) SEQ09880
8010 FORMAT(/,IX,13,' LIFT N/A (PLUME MISSES HILL)') SEQ09890
8020 FORMAT(IX,13,' WRAP N/A (PLUME MISSES HILL)') SEQ09900
9315 FORMAT(/' PLUME IS BELOW MIX HT IN UNSTABLE LAYER, NO CTDM ', SEQ09910
* 'PREDICTIONS',/,' YEAR-',12,' MONTH-',12,' DAY-',12, SEQ09920
* ' JCD-M3,' HOUR-M2/) SEQ09930
9335 FORMAT(/' USTAR MISSING , NO CTDM PREDICTIONS THIS HOUR', SEQ09940-
* /' YEAR-1,12,' MONTH-',12,' DAY-1,12,' JCD-',I3,' HOUR-',I2/) SEQ09950
9345 FORMAT(/' 20 MISSING , NO CTDM PREDICTIONS THIS HOUR', SEQ09960
* /' YEAR-',12,' MONTH-',12,' DAY-',12,' JCD-',I3,' HOUR-',I2/) SEQ09970
9355 FORMAT(/' MISSING MET. INPUT, NO CTDM PREDICTIONS THIS HOUR1, SEQ09980
* /' YEAR-',12,' MONTH-',12,' DAY-1,12,' JCD-',I3,' HOUR-',I2/) SEQ09990
9365 FORMAT(/' FLOW FIELD ALGORITHM SUBJECTED TO INPUT DATA BEYOND ',SEQ10000
* 'ITS DESIGN CRITERIA;',/,1 NO CTDM PREDICTIONS: YEAR - ',12, SEQ10010
* ' MONTH - ',12,' DAY - ',12,' JCD - ',13,' HOUR - ',I2/) SEQ10020
9375 FORMAT(/' WIND SPEED LT 1 M/S, NO CTDM PREDICTIONS THIS HOUR', SEQ10030
* /' YEAR-',12,' MONTH-',12,' DAY-',12,' JCD-1,13,' HOUR-',I2/) SEQ10040
9500 FORMAT(' DAY - ',14) SEQ10050
C SEQ10060
END SEQ10070
It*
107
-------
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 SIGB(DELH, SIGYB, SIGZB)
PURPOSE: CALCULATE SIGMA-Y AND SIGMA-Z CONTRIBUTION DUE TO BUOYANCY
INDUCED GROWTH
ASSUMPTIONS: THE CONTRIBUTION DUE TO BOUYANCY IS A FUNCTION OF THE
PLUME RISE AND IS THE SAME FOR SIGMA-Y AND SIGMA-Z.
ARGUMENTS:
PASSED:
DELH
RETURNED:
SIGYB
SIGZB
REAL PLUME RISE ABOVE STACK TOP (M)
REAL SIGMA-Y DUE TO BUOYANCY
REAL SIGMA-Z DUE TO BUOYANCY
I/O: NONE
CALLING ROUTINES: SEQMOD
EXTERNAL ROUTINES: NONE
REAL
DELH, SIGYB, SIGZB
0.2857143 - 1/3.5
EQN 24 OF CTDM USER'S GUIDE
SIGYB -
SIGZB -
RETURN
END
(DELH*0.2857143)
SIGYB
SGB00010
-SGB00020
SGB00030
SGB00040
SGB00050
SGB00060
SGB00070
SGB00080
SGB00090
SGB00100
SGB00110
SGB00120
SGB00130
SGB00140
SGB00150
SGB00160
SGB00170
SGB00180
SGB00190
SGB00200
SGB00210
-SGB00220
SGB00230
SGB00240
SGB00250
SGB00260
SGB00270
SGB00230
SGB00290
SGB00300
SGB00310
SGB00320
to?
108
-------
REAL FUNCTION SPEED(Z)
C-
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C-
C
DESCRIPTION: COMPUTES THE UNPERTURBED FLOW SPEED AT HEIGHT 2
ABOVE HC BASED ON A LINEAR SPEED GRADIENT ALF AND THE
SPEED AT PLUME HEIGHT.
ARGUMENTS:
PASSED:
Z REAL HEIGHT (M)
I/O: NONE
CALLING ROUTINES: FLOW
EXTERNAL ROUTINES: NONE
INTRINSIC FUNCTIONS: NONE
INCLUDE FILES: NONE
COMMON BLOCKS: VARS
INCLUDE
'VARS.CMN'
SPEED - US + ALF * ( Z + HC - HPL )
IF( SPEED .LT. 1.0 ) SPEED - 1.0
RETURN
END
SPD00010
-SPD00020
SPD00030
SPD00040
SPD00050
SPD00060
SPD00070
SPDOOOSO
SPD00090
SPD00100
SPD00110
SPD00120
SPD00130
SPD00140
SPD00150
SPD00160
SPD00170
SPD00180
SPD00190
SPD00200
SPD00210
SPD00220
SPD00230
SPD00240
SPD00250
SP000260
SPD00270
SPD00280
SPD00290
SPD00300
(0*
109
-------
SUBROUTINE SRISE(IFLAG, DELH, IRISE) SRS00010
C SRS00020
C PURPOSE: THIS ROUTINE CALCULATES FINAL PLUME RISE FOR THE STABLE SRS00030
C CASE ( L > 0 ) SRS00040
C SRS00050
C METHODS: SRS00060
C SRS00070
C IF THE BUOYANCY FLUX (F) IS ZERO THEN THE MOMENTUM RISE IS SRS00080
C THE MINIMUM VALUE FROM THE FOLLOWING EQUATIONS: SRS00090
C EQN (6) 3*D*VS/U SRS00100
C E'QN (7) 1.5*(VS*VS*D*D*TA/(4*TS*U))**0.333*S**-0.1667 SRS00110
C OTHERWISE THE PLUME RISE IS THE MINIMUM VALUE FROM THE FOLLOWINGSRS00120
C EQUATIONS: SRS00130
C EQN (8) 1.3*FB/(U*USTAR**2) * (1+HS/DELH)**0.6667 OR SRS00140
C EQN (9) 1.6*(FB*X*X)**0.3333/U, SRS00150
C X -119*F**0.4 IF FB>55; X - 49*F**0.625 IF FB<=55SRS00160
C EQN(IO) 2.6*(FB/(U*S))**0.3333 SRS00170
C EQN(ll) 4*FB**0.25*S**-0.375 SRS00180
C IF EQN (7) IS USED, THEN TEST THE NEUTRAL HIGH WIND MODEL: SRS00190
C EQN (12) 1.54*(FB/(U*USTAR**2))**0.6667 * HS**0.3333 SRS00200
C AND IF THE RESULT OF EQN(12) IS LESS THAN EQN(8-11), USE EQN(12)SRS00210
C SRS00220
C IN THE CTDM USER'S GUIDE, THE ABOVE EQUATIONS (6-12) CORRESPOND SRS00230
C TO EQUATIONS 25a, 25b, 29, 26, 31a, and 31b, RESPECTIVELY. SRS00240 .
C SRS00250
C ASSUMPTIONS: SRS00260
C - CONVERGENCE IS REACHED WHEN TWO CONSECUTIVE ESTIMATES ARE SRS00270
C WITHIN 1%. AT THE END OF ITERATION # MAXITR, THE AVERAGE OF SRS00280
C THE LAST TWO ESTIMATES IS USED. HOWEVER, IF THE SECOND SRS00290
C ITERATION PRODUCES A PLUME RISE HIGHER THAN THE FIRST, THEN SRS00300
C THE SCHEME IS DIVERGING, AND THE FIRST ITERATION RESULT IS SRS00310
C USED. SRS00320
C - MINIMUM WIND SPEED IS 0.1 M/S SRS00330
C SRS00340-
C ARGUMENTS: SRS00350
C PASSED: SRS00360
C IFLAG INT 1 IF PARTIAL PENETRATION CALCULATION, SRS00370
C 0 OTHERWISE • SRS00380
C SRSOCI390
C RETURNED: SRSOCI400
C DELH REAL FINAL PLUME RISE ABOVE STACK TOP (M) SRS00410
C IRISE INT FLAG INDICATING WHICH PLUME RISE EQUATION WAS SRS00420
C USED TO CALCULATE DELH SRS00430
C SRS00440
C CALLING ROUTINES: SEQMOD SRS00450
C SRS00460
C EXTERNAL ROUTINES: SRS00470
C GETWS - FUNCTION WHICH RETURNS THE WIND SPEED AT HEIGHT Z SRS004SO
C GETDTH - FUNCTION WHICH RETURNS DTHETA/DZ AT HEIGHT Z SRS00490
C PICK4 - SUBROUTINE WHICH RETURNS THE MINIMUM VALUE OF FOUR SRS00500
C VARIABLES AND A FLAG INDICATING WHICH VARIABLE WAS SRS00510
C PICKED SRS00520
C SRS00530
C INTRINSIC FUNCTIONS: ABS AMAX1 SRSOOS40
C SRS00550
C COMMON BLOCKS: STACK SFCMET VARS SRS00560
C SRS00570
C SRS00580
INCLUDE 'STACK.CMN' SRS00590
INCLUDE 'SFCMET.CMN1 SRS00600
110
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
110
C_.._
INCLUDE ' VARS . CMN '
REAL DELH
INTEGER IRISE, IFLAG
REAL S16, US, UP, USTAR2, DH1, DH2,
1 DH3, DHG, G, ERROR, TEMP, GTA, HS13,
2 DH4 , DH5
INTEGER ITR, MAXITR
DATA " MAXITR/ 5/
DATA G/ 9.80616/
DATA ERROR/ 0.0 I/
US - AMAX1(USTKTP,0.1)
GTA - G/TA
USTAR2 - USTARO*USTARO
IF(IFLAG .EQ. 0) THEN
SDTHDZ-GETDTH (HS )
ELSE
SDTHDZ - 0.005
ENDIF
TEST FOR MOMENTUM OR BUOYANCY RISE
"-
IF(FB .GT. 0.0) GO TO 110
MOMENTUM RISE
DH1 - 3.0*DS*VS/US
IF(SDTHDZ.LE.O.O) THEN
IRISE - 6
DELH • DH1
RETURN
ENDIF
S16 - 1.0/(GTA*SDTHDZ)**0. 16667
DH2 - (1.5*(VS*VS*DS*DS*TA/(4.0*TS*US))**0. 33333) *S16
PICK MINIMUM RISE FROM EQUATIONS (6) AND (7)
DH3 - 999999.
DH4 - 999999.
CALL PICX4(DH1, DH2, DH3, DH4, DELH, IRISE)
IRISE - IRISE+5
RETURN
NEUTRAL/STABLE BUOYANCY RISE
FOR BUOYANT PLUME RISE, THE WIND SPEED USED IN THE CALCULATION
IS THAT HALFWAY BETWEEN THE STACK-TOP HEIGHT AND THE LATEST
PLUME HEIGHT ESTIMATE. SINCE FINAL PLUME RISE (DHG) IS A
FUNCTION OF THE WIND SPEED USED IN THE COMPUTATION, AN ITERATIV]
SCHEME MUST BE USED. FOR THE FIRST GUESS, THE WIND SPEED USED
IS THAT AT STACK-TOP HEIGHT (US) . A MAXIMUM OF 5 ITERATIONS IS
ATTEMPTED. FOR EACH ITERATION, THE PLUME RISE (FOR GETTING
PLUME RISE MIDPOINT METEOROLOGICAL VARIABLES) IS SET TO THE
AVERAGE OF THE PREVIOUS 2 ESTIMATES. DHO IS THE SECOND OLDEST
GUESS, WHILE DH<1,2,3,4> IS THE MOST RECENT GUESS.
UP - US
DHG - 1.3*FB/(UP*USTAR2)
SRS00610
SRS00620
SRS00630
SRS00640
SRS00650
SRS00660
SRS00670
SRS00680
SRS00690
SRS00700
SRS00710
SRS00720
SRS00730
SRS00740
SRS00750
SRS00760
SRS00770
SRS00780
SRS00790
SRS00800
SRS00810
SRS00820
SRS00830
SRS00840
SRS00850
SRS00860
SRS00870
onff rtrto o rt
SKS00880
SRS00890
B&O nr\Gf\f\
5KSOO9QO
SRS00910
SRS00920
SRS00930
SRS00949-
SRS00950
SRS00960
SRS00970
SRS00980
SRS00990
SRS01000
SRS01010
SRS01020
SRS01030
SRS01040
SRS01050
SRS01060
SRS01070
SRS01080
SRS01090
3SRS01100
SRS01110
SRS01120
SRS01130
SRS01140
SRS01150
SRS01160
SRS01170
SRS01180
cncm ion
SKaOliyO
SRS01200
100
111
-------
IF(DHG.GT.XMH) THEN SRS01210
DH1 - 999999. SRS01220
GO TO 130 SRS01230
ENDIF SRS01240
DHO - DHG SRS01250
DO 120 ITR»1,HAXITR SRS01260
DH1 - 1.3*FB/(UP*USTAR2)*(1.0+HS/DHG)**0.66667 SRS01270
IF(ABS(DH1-DHG) .LT. ERROR*DH1) GO TO 130 SRS01280
IF(ITR .EQ. 2 .AND. DH1 .GT. DHG) THEN SRS01290
DH1 - DHG SRS01300
GO TO 130 SRS01310
ENDIF SRS01320
UP - GETWS(HS+0.5*DH1) SRS01330
DHG - 0.5*(DHO-(-DHl) SRS01340
DHO - DH1 SRS01350
IF(UP .LE. 0.0) GO TO 125 SRS01360
120 CONTINUE SRS01370
125 DH1 - DHG SRS01380
C EQUATION (9) SRS01390
130 IF(FB .LE. 55.0) THEN SRS01400
XSTAR - 14.0 * FB**0.625 SRS01410
ELSE SRS01420
XSTAR * 34.0 * FB**0.40 SRS01430
ENDIF SRS01440
XFIN - 3.5*XSTAR SRS01450
UP - US SRS01460
DHG - 1.6*(FB*XFIN*XFIN)**0.33333/UP SRS01470
DHO - DHG SRS01480
UP-GETWS(HS+0.5*DHG) SRS01490
DO 140 ITR-1,MAXITR SRS01500
DH2 - 1.6*(FB*XFIN*XFIN)**0.33333/UP SRS01510
IF(ABS(DH2-DHG) .LT. ERROR*DH2) GO TO 150 SRS01520
IF(ITR .EQ. 1 .AND. DH2 .GT. DHG) THEN SRS01530
DH2 - DHG SRS01540-
GO TO 150 SRS01550
ENDIF SRS01560
UP - GETWS(HS+0.5*DH2) SRS01570
DHG - 0.5*(DHO+DH2) SRS01580
DHO - DH2 SRS01590
IF(UP .LE. 0.0) GO TO 145 SRS01600
140 CONTINUE . SRS01610
145 DH2-DHG SRS01620
C EQUATION (10) SRS01630
150 IF(SDTHDZ.LE.O.O) THEN SRS01640
DELH - AMIN1(DH1,DH2) SRS01650
IF(DHl.LT.DHZ) THEN SRS01660
IRISE - 8 SRS01670
ELSE SRS01680
IRISE - 9 SRS01690
ENDIF SRS01700
RETURN SRS01710
ENDIF SRS01720
UP - US SRS01730
DTHDZ - SDTHDZ SRS01740
DHG - 2.6*(FB/(UP*GTA*DTHDZ))**0.33333 SRS01750
DHO - DHG SRS01760
UP - GETWS(HS+0.5*DHG) SRS01770
IF(IFLAG.EQ.O) DTHDZ - GETDTH(HS+0.5*DHG) SRS01780
IF(UP .LE. 0.0 .OR. DTHDZ .LE. 0.0) GO TO 165 SRS01790
DO 160 ITR - 1,HAXITR SRS01800
112
-------
DH3 - 2.6*(FB/(UP*GTA*DTHDZ))**0.33333 SRS01810
IF(ABS(DH3-DHG) .LT. ERROR*DH3) GO TO 170 SRS01820
IF(ITR .EQ. 1 .AND. DH3 .GT. DHG) THEN SRS01830
DH3 - DHG SRS01840
GO TO 170 SRS01850
ENDIF SRS01860
UP - GETWS(HS+0.5*DH3) SRS01870
IF(IFLAG.EQ.O) DTHDZ = GETDTH(HS+0.5*DH3) SRS01880
DHG - 0.5*(DHO+DH3) SRS01890
DHO - DH3 SRS01900
IF(UP .LE. 0.0 .OR. DTHDZ .LE. 0.0) GO TO 165 SRS01910
160 CONTINUE SRS01920
165 DH3 - DHG SRS01930
c EQUATION (11) SRS01940
170 TEMP - 4.0*FB**0.25 SRS01950
DTHDZ - SDTHDZ SRS01960
DHG - TEMP/(GTA*DTHDZ)**0.375 SRS01970
DHO - DHG SRS01980
IF(IFLAG.EQ.l) GO TO 185 SRS01990
DTHDZ - GETDTH(HS+0.5*DHG) SRS02000
IF(DTHDZ .LE. 0.0) GO TO 185 SRS02010
DO 180 ITR - 1,MAXITR SRS02020
DH4 - TEMP/(GTA*DTHDZ)**0.375 SRS02030
IF(IFLAG.EQ.l) GO TO 190 SRS02040
IF(ABS(DH4-DHG) .LT. ERROR*DH4) GO TO 190 SRS02050
IF(ITR .EQ. 1 .AND. DH4 .GT. DHG) THEN SRS02060
DH4 - DHG SRS02070
GO TO 190 SRS02080
ENDIF SRS02090
DTHDZ * GETDTH(HS-t-0.5*DH4) SRS02100
DHG • 0.5*(DHO+DH4) SRS02110
DHO - DH4 SRS02120
IF(DTHDZ .LE. 0.0) GO TO 185 SRS02130
180 CONTINUE SRS02144-
185 DH4 - DHG . SRS02150
C PICK MINIMUM RISE FROM EQUATION'S (8), (9), (10), (11) SRS02160
190 CALL PICK4(DH1, DH2, DH3, DH4, DELH, IRISE) SRS02170
IRISE - IRISE+7 SRS02180
C TEST FOR NEUTRAL HIGH HIND MODEL SRS02190
IF(IRISE .NE. 7 .OR. IFLAG .EQ.l) RETURN SRS02200
C EQUATION (12) SRS02210
UP - US SRS02220
HS13 - HS**0.33333 SRS02230
TEMP - FB/USTAR2 SRS02240
DHG - 1.54*(TEMP/UP)**0.66667*HS13 SRS02250
UP * GETWS(HS+0.5*DHG) SRS02260
DHO - DHG SRS02270
DO 200 ITR - 1,MAXITR SRS02280
DH5 - 1.54*(TEMP/UP)**0.666«7*HS13 SRS02290
IF(ABS(DH5-DHG) .LT. ERROR*DH5) GO TO 210 SRS02300
UP - GETWS(HS+0.5*DH5) SRS02310
DHG - 0.5*(DHO+DH5) SRS02320
DHO - DH5 SRS02330
200 CONTINUE SRS02340
DH5 - DHG SRS02350
210 IF(DH5 .LT. DELH) THEN SRS02360
DELH - DH5 SRS02370
IRISE - 12 SRS02380
ENDIF SRS02390
C SRS02400
lie
113
-------
SRS02410
SRS02420
114
-------
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 SUN { JCD , TZONE , BLAT , ALONG , HRRISE , HRSET)
PURPOSE:
SUN WILL COMPUTE THE HOURS OF SUNRISE AND SUNSET AT A GIVEN
LOCATION FOR A GIVEN DAY OF THE YEAR.
ARGUMENTS
PASSED:
JCD IWT JULIAN DAY (INPUT)
TZONE REAL TIME ZONE (# OF HOURS BEFORE GMT, > 0 IN WEST)
BLAT REAL LATITUDE, POSITIVE NORTH
ALONG REAL LONGITUDE, POSITIVE WEST
RETURNED:
HRRISE REAL HOUR OF SUNRISE (WITH FRACTIONAL PART)
HRSET REAL HOUR OF SUNSET (WITH FRACTIONAL PART)
EXTERNAL ROUTINES: NONE
CALLING ROUTINES: SEQMOD
INTRINSIC FUNCTIONS: FLOAT SIN COS TAN ASIN ACOS
REFERENCES: ADAPTED FROM EPA PREPROCESSOR "RAMMET"
INTEGER JCD
REAL TZONE, BLAT, ALONG, HRRISE, HRSET
DAY-FLOAT (JCD)
ALAT - BLAT/57. 29578
D - DAY/365.242 * 360.
DR - D/57. 29578
DR2 - 2.0 * DR
SIGMA * D +-273.9348 + 1 . 914827*SIN(DR) - 0. 079525*COS (DR) +
X 0.019938*SIN(DR2) - 0.00162*COS(DR2)
AMM - 12.0 + 0.12357*SIN(DR) - 0. 004289*COS (DR) +
X 0. 153809 *SIN(DR2) + 0.06078 3 *COS(DR2)
0.39785-SIN(23. 44383)
DELTA - ASIN(0.39785*SIN(SIGMA/57. 29579))
H2 * ACOS ( -TAN ( ALAT) *TAN( DELTA)) * 57.29578
HRRISE - AMM - (H2 - ALONG) /IS. - TZONE
HRSET - AMM + (H2 + ALONG) /IS. - TZONE
RETURN
END
SUN00010
SUN00030
SUN00040
SUN00050
SUN00060
SUN00070
SUN00080
SUN00090
SUN00100
SUN00110
SUN00120
SUN00130
S UNO 0140
SUN00150
SUN00160
SUN00170
SUN00180
SUN00190
SUN00200
SUN00210
SUN00220
SUN00230
SUN00240
SUN00250
SUN00260
SUN00280
SUN00290
SUN00300
SUN00310
SUN00320
SUN00330
SUN00340_
SUN00350
SUN00360
SUN00370
SUN00380
SUN00390
' SUN00400
SUN00410
SUN00420
SUN00430
SUN00440
SUN00450
SUN00460
SUN00470
SUN00480
SUN00490
SUN00500
111
115
-------
SUBROUTINE TOPN(CHI, NREC, IFLAG, GGSS)
C SUBROUTINE: TOPN
C
C PURPOSE: INITIALIZE, UPDATE OR PRINTOUT TOP N TABLE. N IS DEFINED BY
C THE PARAMETER MAXTOP IN 'PARAMS.INC'
C
C ARGUMENTS:
C PASSED:
C CHI REAL CONCENTRATION ARRAY
C NREC INT NUMBER OF RECEPTORS
C IFLAG INT -1 - INITIALIZE ARRAY
C 0 - CHECK TOP 5
C +1 - *RINT RESULTS
C GGSS CHAR CHARACTER 'G1 OR 'S' FOR CONCENTRATION UNITS
C RETURNED: NONE
C
C I/O:
C INPUT: NONE
C
C OUTPUT: TOPS TABLE TO UNIT IOUT
C
C CALLING ROUTINES: SEQMOD INPAR
C
C EXTERNAL ROUTINES: PAGE
C
C INTRINSIC FUNCTIONS: MOD
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: IO.CMN TIME.CMN TOP.CMN
C
C
INCLUDE 'PARAMS.INC'
INCLUDE 'IO.CMN1
INCLUDE ' TIME.CMN1
.INCLUDE 'TOP.CMN'
C
C DEFINE ARGUMENTS
INTEGER NREC, IFLAG
REAL CHI (NREC)
CHARACTER GGSS
C
C DEFINE LOCAL VARIABLES
INTEGER I, IT, J, NR, YES, NRTOP ( MAXTOP ), KONTIN
CHARACTER CHR1 (MAXTOP, MAXREC) , STAR, BLANK
CHARACTER*? CONTIN(2)
DATA YES/1/, KONTIN/ I/
DATA STAR/'*'/, BLANK/' '/, CONTIN/ ' ^'(CONT.)'/
C
C START
IF( IFLAG ) 100, 200, 300
C
C INITIALIZE TOP ARRAY
100 DO 110 I- 1, MAXTOP
TOPTOP(I) - -9999.
DO 120 J-l, MAXREC
CTOP(I,J) - -999.
TOPTIM(I,J) - 0
TPN00010
TPN00030
TPN00040
TPN00050
TPN00060
TPN00070
TPN00080
TPN00090
TPN00100
TPN00110
TPN00120
TPN00130
TPN00140
TPN00150
TPN00160
TPN00170
TPN00180
TPN00190
TPN00200
TPN00210
TPN00220
TPN00230
TPN00240
TPN00250
TPN00260
TPN00270
TPN00280
TPN00290
TPN00300
TPN00310
TPN00320
^fTtOWrtrt^ •> f\
— TfnOOj Ju
TPN00340-
TPN00350
TPN00360
TPN00370
TPN00380
TPN00390
TPN00400
TPN00410
TPN00420
TPN00430
TPN00440
TPN00450
TPN00460
TPN00470
TPN00480
TPN00490
TPN00500
TPN00510
TPN00520
TPN00530
TPN00540
TPN00550
TPN00560
TPN00570
TPN00580
TPN00590
TPN00600
111
116
-------
120
110
C
C
200
220
230
240
210
C
C
C
300
320
310
330
C
C
&
&
350
C
900
C
6010
CONTINUE
CONTINUE
GO TO 900
CHECK FOR TOP MAXTOP AT EACH RECEPTOR
DO 210 NR-1,NREC
IF(CHI(NR) .GT. CTOP (MAXTOP, NR) ) THEN
DO 220 IT - MAXTOP-1, 1, -1
IF( CHI(NR) .LE. CTOP(IT,NR) ) GOTO 230
CTOP(IT+1,NR) - CTOP(IT,NR)
TOPTIM(IT+1,NR) - TOPTIM(IT,NR)
IF(IT .EQ. 1) THEN
CTOP(1,NR) - CHI(NR)
TOPTIM(1,NR) - KJCD * 100 + KHR
GO TO 240
ENDIF
CONTINUE
CTOP(IT+1,NR) - CHI(NR)
TOPTIM(IT+1,NR) - KJCD * 100 + KHR
CONTINUE
ENDIF
CONTINUE
GO TO 900
FIND TOP EACH MAXTOP
DO 310 I-l, MAXTOP
DO 320 J-1,NREC
IF(CTOP(I,J) .GT. TOPTOP(I)) THEN
NRTOP(I) - J
TOPTOP(I) - CTOP(I,J)
ENDIF
CHR1(I,J) - BLANK
CONTINUE
CONTINUE
DO 330 I-l, MAXTOP
CHR1(I,NRTOP(I)) - STAR
CONTINUE
PRINT TOP ARRAY
DO 350 NR-1,NREC
IF(MOD(NR,40) .EQ. 1) THEN
IF(NR .GT. 1) KONTIN - 2
CALL PAGE (YES)
WRITE (IOUT, 6010) MAXTOP, GGSS, CONTIN (KONTIN)
ENDIF
IF(MOD(NR,10) .EQ. 1) WRITE (IOUT, 6020)
WRITE (IOUT, 6030) NR, (CTOP(I,NR) ,CHR1(I,NR) ,
(TOPTIM(I,NR)/100), (MOD(TOPTIM(I,NR) ,100)) ,
I-l, MAXTOP)
CONTINUE
RETURN
FORMAT (
1 REC TOP ',11,' CONCENTRATIONS [U1 , Al, '/M**3] AT EACH '
•RECEPTOR ',A7,/,
1 * HIGHEST (JCD,HR) SECOND (JCD,HR) THIRD (JCD,HR)
1 FOURTH (JCD.HR) ',/,
TPN00610
TPN00620
TPN00630
TPN00640
TPN00650
TPN00660
TPN00670
TPN00680
TPN00690
TPN00700
TPN00710
TPN00720
TPN00730
TPN00740
TPN00750
TPN00760
TPN00770
TPN00780
TPN00790
TPN00800
TPN00810
TPN00820
TPN00830
TPN00840
TPN00850
TPN00860
TPN00870
TPN00880
TPN00890
TPN00900
TPN00910
TPN00920
TPN00930
TPN00940
TPN00950
TPN00960
TPN00970
TPN00980
TPN00990
TPN01000-
TPN01010
TPN01020
TPN01030
TPN01040
TPN01050
TPN01060
TPN01070
TPN01080
TPN01090
TPN01100
TPN01110
TPN01120
TPN01130
TPN01140
TPN01150
, TPN01160
TPN01170
',TPN01180
TPN01190
i TPMQ12QO
(11
117
-------
& ' ') TPN01210
6020 FORMAT(' ') TPN01220
6030 FORMAT(1X,I3,4(2X,1PE8.2,A1, '(',13, ', ',12,') ')) TPN01230
END TPN01240
118
-------
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
SUBROUTINE TERAX( SMAJ, SMIN, EMAJ, EMIN, RELIEF, HT,
* BASE, ABMAX, AAX, BAX)
DESCRIPTION: GIVEN A CONTOUR HEIGHT, SUBROUTINE RETURNS THE MAJOR
AND MINOR AXIS LENGTHS.
ARGUMENTS :
PASSED
SMAJ REAL SCALE LENGTH FOR MAJOR AXIS
SMIN REAL SCALE LENGTH FOR MINOR AXIS
EMAJ REAL EXPONENT FOR MAJOR AXIS
EMIN REAL EXPONENT FOR MINOR AXIS
RELIEF REAL RELIEF HEIGHT
HT REAL HEIGHT OF CONTOUR
BASE REAL HILL BASE HEIGHT
ABMAX REAL MAX VALUE OF AAX, BAX ( AAX <- BAX < ABMAX )
(AXIS LENGTHS NOT ALLOWED TO EXCEED DISTANCE
FROM SOURCE TO HILL CENTER)
RETURNED
AAX REAL MAJOR AXIS LENGTH
BAX REAL MINOR AXIS LENGTH
CALLING ROUTINES: SEQMOD
EXTERNAL ROUTINES: NONE
INTRINSIC FUNCTIONS: NONE
COMMON BLOCKS: CONST
DEFINE ARGUMENTS
REAL SMAJ, SMIN, EMAJ, EMIN, RELIEF, HT, BASE, ABMAX, AAX, BAX
INCLUDE ' CONST . CMN '
DEFINE LOCAL VARIABLES
REAL HCONTR
START
HCONTR - HT - BASE
IF (HCONTR .LE. SMALL) THEN
AAX-ABMAX*0.99
BAX-ABMAX*0.99
RETURN
ENDIF
SEE EQN 13 IN TERRAIN PREPROCESSOR MANUAL FOR AAX, BAX
AAX - SMAJ * (RELIEF/HCONTR-1. )**(!. /EMAJ)
BAX - SMIN * (RELIEF/HCONTR-1. )**(!. /EMIN)
IF (AAX .GT. ABMAX) AAX - ABMAX * 0.99
IF (BAX .GT. AAX) BAX - AAX
RETURN
END
TRX00010
TRX00020
TRX00040
TRX00050
TRX00060
TRX00070
TRX00080
TRX00090
TRX00100
TRX00110
TRX00120
TRX00130
TRX00140
TRX00150
TRX00160
TRX00170
TRX00180
TRX00190
TRX00200
TRX00210
TRX00220
TRX00230
TRX00240
TRX00250
TRX00260
TRX00270
TRX00280
TRX00290
TRX00300
TRX00320
TRX00330
TRX00340
TRX00355"
TRX00360
TRX00370
TRX00380
TRX00390
TRX00400
TRX00410
TRX00420
TRX00430
TRX00440
TRX00450
TRX00460
TRX00470
TRX00480
TRX00490
TRX00500
TRX00510
TRX00520
TRX00530
TRX00540
TRX00550
TRX00560
TRX00570
TRX00580
119
-------
IRISE)
THIS ROUTINE CALCULATES
CASE ( L < 0 ) .
FINAL PLUME RISE FOR THE UNSTABLE
IF THE BUOYANCY FLUX (FB) IS
EQN (1) 3*D*VS/U
OTHERWISE THE PLUME RISE IS THE
EQUATIONS:
(2)
(3)
X
(4)
(5)
EQN
EQN
EQN
EQN
URS00010
•URS00020
URS00030
URS00040
URS00050
URS00060
URS00070
URS00080
URS00090
URS00100
URS00110
MINIMUM VALUE FROM THE FOLLOWINGURS00120
URS00130
1.3*FB/(U*USTAR**2) * (1+HS/DELH)**0. 6667 URS00140
1.6*(FB*X*X)**0.3333/U, URS00150
-119*F**0.4 IF FB>55? X - 49*F**0.625 IF FB<=»55URS00160
ZERO THEN THE MOMENTUM RISE IS
4.3*(FB/U)**0.6 * HSTAR**-0.4
FB/(U*0.4*WSTAR)**2 * (1+2*HS/DELH)**2
SUBROUTINE URISE(DELH,
C
C SUBROUTINE: URISE
C
C PURPOSE:
C
C
C METHODS:
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 COMMON: STACK SFCMET VARS
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES:
C GETWS - FUNCTION WHICH RETURNS THE WIND SPEED AT HEIGHT Z
IN THE CTDM USER'S GUIDE,
TO EQUATIONS 25a, 29, 26,
THE ABOVE EQUATIONS (1-5)
27, AND 28, RESPECTIVELY.
CORRESPOND
ASSUMPTIONS:
- - CONVERGENCE IS REACHED WHEN TWO CONSECUTIVE ESTIMATES ARE
WITHIN 1%
- MINIMUM WIND SPEED IS 0.1 M/S
ARGUMENTS:
PASSED: NONE
RETURNED:
DELH REAL FINAL PLUME RISE ABOVE STACK TOP (M)
IRISE INT FLAG INDICATING WHICH PLUME RISE EQUATION WAS
USED TO CALCULATE DELH
C PICK4 - SUBROUTINE WHICH RETURNS THE MINIMUM1 VALUE OF FOUR
C VARIABLES AND A FLAG INDICATING WHICH VARIABLE WAS
C PICKED
C
C INTRINSIC FUNCTIONS: ABS
C
C
REAL
INTEGER
C
DELH
IRISE
INCLUDE
INCLUDE
INCLUDE
'STACK.CMN'
•SFCMET.CMN'
'VARS.CMN1
C
C
DEFINE LOCAL VARIABLES
REAL HSTAR, HSTAR4,
1 DH1, DH2,
INTEGER MAXITR
WD, US, UP, USTAR2,
DH3, DH4, DHG, VONKAR, ERROR
URS00170
URS00180
URS00190
URS00200
URS00210
URS00220
URS00230
URS00240
URS00250
URS00260
URS00270
URS00280
URS00290
URS00300
URS00310
URS00320
URS00330
URS00340-
URS00350
URS00360
URS00370
URS00380
URS00390
URS00400
URS00410
URS00420
URS00430
URS00440
URS00450
URS00460
URS00470
URS00480
URS00490
URS00500
URS00510
URS00520
URS00530
URS00540
URS00550
URS00560
URS00570
URS00580
URS00590
URS00600
120
-------
C TEST
C
110
112
C
DATA MAXITR/5/
DATA ERROR/ 0.0I/
DATA VONKAR/ 0.40/
US - AMAX1(USTKTP,0.1)
USTAR2=USTARO*USTARO
FOR MOMENTUM RISE
IF(FB .GT- 0-0) GO TO 100
EQUATION (1)
DELH-3.0*DS*VS/US
IRISE-1
RETURN
URS00610
URS00620
URS00630
URS00640
URS00650
URS00660
URS00670
URS006SO
URS00690
URS00700
URS00710
URS00720
URS00730
UHS00740
URS00750
URS00760
C
C FOR BUOYANT PLUME RISE, THE WIND SPEED USED IN THE CALCULATION
C IS THAT HALFWAY BETWEEN THE STACK-TOP HEIGHT AND THE LATEST
C PLUME HEIGHT ESTIMATE. SINCE FINAL PLUME RISE (DHG) IS A
C FUNCTION OF THE WIND SPEED USED IN THE COMPUTATION, AN ITERATIVEURS00770
C SCHEME MUST BE USED. FOR THE FIRST GUESS, THE WIND SPEED USED URS00780
C IS THAT AT STACK-TOP HEIGHT (US). A MAXIMUM OF 5 ITERATIONS IS URS00790
C ATTEMPTED. FOR EACH ITERATION, THE PLUME RISE (FOR GETTING URS00800
C PLUME RISE MIDPOINT METEOROLOGICAL VARIABLES) IS SET TO THE URS00810
C AVERAGE OF THE PREVIOUS 2 ESTIMATES. DHO IS THE SECOND OLDEST URS00820
C GUESS, WHILE DH<1,2,3,4> IS THE MOST RECENT GUESS. URS00830
C URS00840
CT EQUATION (2) URS00850
100 UP-US URS00860
URS00870
URS00880
URS00890
URS00900
URS00910
URS00920
URS00930
URS00940-
URS009SO
URS00960
URS00970
URS00980
URS00990
URS01000
URS01010
URS01020
URS01030
URS01040
URS01050
URS01060
URS01070
URS01080
URS01090
URS01100
URS01110
URS01120
URS01130
URS01140
URS01150
URS01160
115 CONTINUE URS01170
120 DH2-DHG URS01180
C EQUATION (4) URS01190
URS01200
EQUATION (2)
UP-US
DHG-1.3 *FB/(UP*USTAR2)
DHO - DHG
UP-GETWS(HS+0.5*DHG)
DO 110 ITR - 1,MAXITR
DH1-1.3 *FB/(UP*USTAR2)*(1.0+HS/DHG)**0.6666667
IF(ABS(DH1-DHG) .LT. ERROR*DH1) GO TO 112
UP-GETWS(HS+0.5*DH1)
DHG-0.5 * (DHO+DH1)
DHO - DH1
CONTINUE
DH1 - DHG
EQUATION (3)
IF(FB .LE. 55.0) THEN
XSTAR - 14.0 * FB**0.625
ELSE
XSTAR - 34.0 * FB**0.40
ENDIF
XFIN - 3.5*XSTAR
UP - US
DHG - 1.6*(FB*XFIN*XFIN)**0.33333/UP
DHO - DHG
UP-GETWS(HS+0.5*DHG)
DO 115 ITR-1,MAXITR
DH2 - 1.6*(FB*XFIN*XFIN)**0.33333/UP
IF(ABS(DH2-DHG) .LT. ERROR*DH2) GO TO 120
IF(ITR .EQ. 1 .AND. DH2 .GT. DHG) GO TO 120
UP-GETWS(HS+0.5*DH2)
DHG-0.5*(DHO+DH2)
DHO - DH2
IF(UP .LE. 0.0) GO TO 120
CONTINUE
DH2-DHG
EQUATION (4)
UP-US
//S
121
-------
130
C
140
150
C
C
C
160
HSTAR = -USTARO**3/(VONKAR*EL)
HSTAR4 - 1.0/(HSTAR**0.40)
DHG=4.3*(FB/UP)**0.60*HSTAR4
DHO - DHG
UP-GETWS (HS+0. 5*DHG)
DO 130 ITR=1,MAXITR
DH3-4.3*(FB/UP)**0.60*HSTAR4
IF(ABS(DH3-DHG) .LT. ERROR*DH3) GO TO 140
UP-GETWS(HS+0.5*DH3)
DHG-0.5*(DHO+DH3)
DHO - DH3
CONTINUE
DH3 - DHG
EQUATION (5)
UP-US
WD-0.4*WSTAR
DHG-FB/(UP*WD*WD)
DHO - DHG
DO 150 ITR - 1,HAXITR
DH4-FB/(UP*WD*WD)*(1.0+2.0*HS/DHG)**2
IF(ABS(DH4-DHG) .LT. ERROR*DH4) GO TO 160
UP-GETWS(HS+0.5*DH4)
DHG - (DHO+DH4)/2.0
DHO - DH4
CONTINUE
DH4 - DHG
PICK MINIMUM RISE FROM EQUATIONS (2), (3), (4), (5)
CALL PICX4(DH1, DH2, DH3, DH4, DELH, IRISE)
IRISE-IRISE+1
RETURN
END
URS01210
URS01220
URS01230
URS01240
URS01250
URS01260
URS01270
URS01280
URS01290
URS01300
URS01310
URSOL320
URS01330
URS013-40
URS01350
URS01360
URS01370
URS01380
URS01390
URS01400
URS01410
URS01420
URS01430
URS01440
URS01.450
URS01460
URS01470
URS01480
URS01490
URS01500
URS01510
URS01520
URS01530
URS01540-
122
-------
REAL FUNCTION UVWD( U, V )
C FUNCTION: UVWD
C
C PURPOSE: COMPUTE WIND DIRECTION FROM U,V COMPONENTS. ALSO GOOD FOR
C METEOROLOGICAL DIRECTION GIVEN A DX AND DY.
C
C ASSUMPTIONS: 0/360 DEGREES POINTS NORTH,
C
C LIMITATIONS : A CALM WIND DIRECTION (U-V-0) RETURNS A -1.
C
C ARGUMENTS:
C PASSED
C U REAL U WIND COMPONENT
C V REAL V WIND COMPONENT
C RETURNED FUNCTION VALUE
C UVWD REAL WIND DIRECTION IN DEGREES
C
C CALLING ROUTINES: ANOINT
C
C EXTERNAL ROUTINES: NONE
C
C COMMON BLOCKS: NONE
C
C INTRINSIC FUNCTIONS: ABS ATAN2
C
C
C DEFINE ARGUMENTS
REAL U, V
C DEFINE LOCAL VARIABLES
REAL EPS, R2D, CALM
DATA R2D/ 57.295779 /
DATA EPS/ 5.0E-6 /
DATA CALM/ -1.0 /
C START
IF( ABS(U) .LE. EPS .AND. ABS(V) .LE. EPS ) THEN
UVWD - CALM
ELSE
C ATAN2 RETURNS VALUE BETWEEN -PI <- ANGLE <- +PX
UVWD « ATAN2(U,V) * R2D
C CONVERT TO NORMAL WIND DIRECTION [DEGREES]
IF( UVWD .LT. 0.0 ) THEN
UVWD » 360.0 + UVWD
ELSE IF( UVWD .EQ. 0.0 ) THEN
C NORTH IS RETURNED AS 360 NOT 0
UVWD - 360.0
ENDIF
ENDIF
RETURN
END
UVWOOOIO
UVW00030
UVW00040
UVW00050
UVW00060
UVW00070
UVW00080
UVW00090
UVW00100
UVW00110
UVW00120
UVW00130
UVW00140
UVW00150
UVW00160
UVW00170
UVW00180
UVW00190
UVW00200
UVW00210
UVW00220
UVW00230
UVW00240
UVW00250
UVW00260
UVW00280
UVW00290
UVW00300
UVW00310
UVW00320
UVW00330
UVW0034&-
UVW00350
UVW00360
UVW00370
UVW00380
UVW00390
UVW00400
UVW00410
UVW00420
UVW00430
UVW00440
UVW00450
UVW00460
UVW00470
UVW00480
UVW00490
UVW00500
UVW00510
I lo
123
-------
SUBROUTINE WRAP(QS)
C PURPOSE: HANDLES FLOW BELOW HC
C
C ARGUMENTS:
C PASSED:
C QS REAL EMISSION RATE [G/S]
C RETURNED: NONE
C
C I/O:
C INPUT: NONE
C OUTPUT: UNIT-IOUT WRAP CONCENTRATION (IF ICASE - YES)
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: ERF
C
C INTRINSIC FUNCTIONS: ABS AMAX1 EXP SQRT
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: PARAMS IO CONST PASVAL PASH VARS
C
C
INCLUDE 'PARAMS.INC1
INCLUDE 'PARAMS. CMN'
INCLUDE '10. CMN'
INCLUDE 'CONST. CMN1
INCLUDE 'PASVAL. CMN'
INCLUDE 'PASW.CMN'
INCLUDE 'VARS. CMN'
C
REAL QS
C
C DEFINE LOCAL VARIABLES
REAL ARG1SQ, ARG2SQ, ARGY, ARGYSQ, Bl, B2 , B3, BRAC1, BRAC2 ,
* CO, DENOM, EXP1, EXP2, FAC1, FAC2,
* . SBETA, SIGVSQ, SIGWSQ, SY, SYO, SYOSQ, SYP, SYPSQ,
* SZ, SZO, SZOSQ, SZP, SZPSQ, SZSQ, UVBETI,
* YTO, YTR, ZTO, ZTR
C
CWRAP - 0.0
CLIFT - C
UVBETI-1 . /UVBETA
SIGWSQ-SIGW*SIGW
SIGVSQ-SIGV*SIGV
C DISTANCE TO RECEPTOR AND IMPING. PT. ALONG BETA
S BETA- XRBETA-XS BETA
C TEST FOR RECEPTOR UPWIND OF SOURCE IN BETA COORDINATE SYSTEM
IF(SBETA*UVBETI .LE. 0.) THEN
IF(ICASE .EQ. 1) WRITE (IOUT, 105) NR
RETURN
ENDIF
C TEST FOR SOURCES DOWNWIND OF STAGNATION POINT
IF(SOBETA*UVBETI .LE. 0.) SOBETA - 0.
C SECTION FOR RECS. AND SOURCES UPWIND OF PRIMARY IMPINGEMENT POINT
IF (SOBETA .NE. 0.0) THEN
IF (SBETA/ SOBETA .LE. 1.0) THEN
IF(Z .GT. HC) THEN
WRP00010
WRP00030
WRP00040
WRP00050
WRP00060
WRP00070
WRP00080
WRP00090
WRP00100
WRP00110
WRP00120
WRP00130
WRP00140
WRP00150
WRP00160
WRP00170
WRP00180
WRP00190
WRP00200
WRP00210
WRP00220
WRP00230
^DDft A*5 A n
•WKirUU^4 U
WRP00250
WRP00260
WRP00270
WRP00280
WRP00290
WRP00300
WRP00310
WRP00320
WRP00330
WRP00340-
WRP00350
WRP00360
WRP00370
WRP003SO
WRP00390
WRP00400
WRP00410
WRP00420
WRP00430
WRP00440
WRP00450
WRP00460
WRP00470
WRP00480
WRPOCI490
WRPOCI500
WRP00510
WRP00520
WRP00530
WRP00540
WRP00550
WRP00560
WRP00570
WRP00580
WRP00590
WRP00600 *
III
124
-------
IF(ICASE .EQ. i) WRITE(IOUT,107) NR
RETURN
ENDIF
C COMPUTE TRAVEL TIME
ZTR-SBETA*UVBETI
YTR-ABS(SBETA*UVBETI)
IF((ZTR+ZTV) .LT. 0.) THEN
az-szs
ELSE
C COMPUTE SIGMAS EQNS. 12,19
S'ZSQ-SIGWSQ* (ZTR+ZTV) **2/(l.+. 5* (ZTR+ZTV)/TTLZ)
SZ-SQRT(SZSQ)
ENDIF
SYSQ-SIGVSQ* (YTR+YTV) **2/ (1. + . 5* (YTR+YTV)/TTLY)
SY-SQRT(SYSQ)
C COMPUTE CONCENTRATION AS CHI/Q IN MICROSECONDS PER M**3
C EQN. 47
ARGYSQ-0.5*D*D/SYSQ
IF(ARGYSQ .LT. 30.) THEN
ARG1SQ-0.5*(HPL-Z)**2/SZSQ
ARG2SQ-0.5*(HPL+Z)**2/SZSQ
EXP1-0.
EXP2-0.
IF(ARG1SQ .LT. 30.) EXPI-EXP(-ARGISQ)
IF(ARG2SQ .LT. 30.) EXP2-EXP(-ARG2SQ)
CO-1000000. * QS/(TWOPI*US*SY*SZ)
CWRAP-CO*EXP(-ARGYSQ)*(EXP1+EXP2)
ENDIF
ELSE
C SECTION FOR RECS. DOWNWIND OF PRIMARY IMPINGEMENT POINT
C COMPUTE TRAVEL TIME TO IMPINGEMENT POINT AND RECEPTOR
ZTO-SOBETA*UVBETI
YTO-ABS(SOBETA*UVBETI)
ZTR-(SBETA-SOBETA)*UVBETI+ZTO
YTR-ABS(SBETA*UVBETI)
C COMPUTE THE SIGMA-Z VALUES ....EQN. 12
SZSQ-SIGWSQ*(ZTR+ZTV)**2/(1.0+0.5*(ZTR+ZTV)/TTLZ)
SZOSQ-SIGWSQ*(ZTO+ZTV)**2/(1.0+0.5*(ZTO+ZTV)/TTLZ)
C
C
C
DO NOT ALLOW SZO TO BE ZERO
SZOSQ - AMAX1(SZOSQ,SMALL*SMALL*SZSQ)
SZ-SQRT(SZSQ)
SZO-SQRT(SZOSQ)
C EQN. 46
SZPSQ-SZSQ-SZOSQ
SZP-SQRT(SZPSQ)
C COMPUTE THE SIGMA-Y VALUES EQN. 19
SYSQ-SIGVSQ*(YTR+YTV)**2/(1.+0.5*(YTR+YTV)/TTLY)
SYOSQ-SIGVSQ*(YTO+YTV)**2/(1.+0.5*(YTO+YTV)/TTLY)
SY-SQRT(SYSQ)
SYO-SQRT(SYOSQ)
C EQN. 46
SYPSQ-SYSQ-SYOSQ
SYP-SQRT(SYPSQ)
C COMPUTE THE CONCENTRATION AS CHI/Q IN MICROSECONDS PER M**3
C EQNS. 44,45
ARGYSQ-0.5*D*D/SYSQ
ARGY-SQRT(ARGYSQ)
IF(ARGYSQ .LT. 30.) THEN
WRP00610
WRP00620
WRP00630
WRP00640
WRP00650
WRP00660
WRP00670
WRP00680
WRP00690
WRP00700
WRP00710
WRP00720
WRP00730
WRP00740
WRP00750
WRP00760
WRP00770
WRP00780
WRP00790
WRP00800
WRP00810
WRP00820
WRP00830
WRP00840
WRP008SO
WRP00860
WRP00870
WRP00880
WRP00890
WRP00900
WRP00910
WRP00920
WRP00930
WRP00948-
WRP00950
WRP00960
WRP00970
WRP00980
WRP00990
WRP01000
WRP01010
WRP01020
WRP01030
WRP01040
WRP01050
WRP01060
WRP01070
WRP01080
WRP01090
WRP01100
WRP01110
WRP01120
WRP01130
WRP01140
WRP01150
WRP01160
WRP01170
WRP01180
WRP01190
WRP01200
125
-------
C
101
105
106
107
C
CO=(1000000.*QS/(TWOPI*US*SY))*EXP(-ARGYSQ)
ERFY -1.0
IF(SYO.GT.SMALL) ERFY « ERF(ARGY*SYP/SYO)
CO-CO*(1.+SIGNYE*ERFY)
ARG1SQ-0.5*(HPL-Z)**2/SZSQ
ARG2SQ-0.5*(HPL+Z)**2/SZSQ
IF(ARG1SQ .LT. 30.) THEN
DENOM-SQR2*SZ*SZO*SZP
B1-HC*SZSQ
B2-Z*SZOSQ
B3-HPL*SZPSQ
IF(DENOM.GE.SMALL) THEN
BRAC1-ERF((B1-B2-B3)/DENOM)+ERF( (B1+B2+B3)/DENOM)
IF(BRAC1 .LT. 0.) BRACl-0.
BRAC2-ERF( (B1+B2-B3)/DENOM)+ERF( (Bl-B2-i-B3)/DENOM)
IF(BRAC2 .LT. 0.) BRAC2-0.
ELSE
IF(B2.GT.B1) THEN
BRAC1 - 0.0
BRAC2 - 0.0
ELSE
BRAC1 - 2.0
BRAC2 - 2.0
ENDIF
ENDIF
FAC1-EXP(-ARG1SQ)
IF(ARG2SQ .GT. 30.) THEN
FAC2-0.
ELSE
FAC2-EXP(-ARG2SQ)
ENDIF
CWRAP - (CO/(2.*SZ))*(FAC1*BRAC1+FAC2*BRAC2)
ENDIF
ENDIF
ENDIF
ENDIF
CTOTAL - CLIFT + CWRAP
IF(SOBETA.EQ.O.O) THEN
IF(ICASE .EQ. 1) WRITE(IOUT,106) NR
ELSE
IF(ICASE .EQ. 1)
1 WRITE(IOUT,101)NR,ABS(SBETA),D,Z,HPL-Z,SY,SZ,SY,SZ,
2 CWRAP,NR,CTOTAL
ENDIF
SET C TO TOTAL CONCENTRATION
C - CTOTAL
RETURN
FORMAT(1X,I3,' W1,F8.0,3X,F8.1,2X,F7.1,2X,F7.1,IX,2F6.1,IX,
& 2F6.1,1X,1PE10.4,/,1X,I3,' TOTAL*,T71,1PE10.4)
FORMAT(IX,13,20X,'RECEPTOR LIES UPWIND OF SOURCE IN ',
* 'BETA COORD. SYS')
FORMAT(IX,13,' WRAP N/A (PLUME MISSES HILL)1)
FORMAT(IX,13,* WRAP N/A (REC. UPWIND OF HILL OR ABOVE HC)')
END
WRP01210
WRP01220
WRP01230
WRPQ1240
WRP01250
WRP01260
WRP01270
WRP01280
WRP01290
WRP01300
WRP01310
WRP01320
WRP01330
WRP01340
WRP01350
WRP01360
WRP01370
WRP013SO
WRP01390
WRP01400
WRP01410
WRP01420
WRP01430
WRP01440
WRP01450
WRP01460
WRP01470
WRP01480
WRP01490
WRP01500
WRP01510
WRP01520
WRP01530
WRP01540-
WRP01550
WRP01560
WRP01570
WRP01580
WRP01590
WRP01600
WRP01610
WRP01620
WRP01630
WRP01640
WRP01650
WRP01660
WRP01670
WRP01680
WRP01690
WRP01700
WRP01710
WRP01720
WRP01730
WRP01740
WRP01750
WRP01760
126
-------
SUBROUTINE WRAPIN(TMU, TNU ,SMU,SNU, XSMAJ, YSMAJ)
C PURPOSE: COMPUTES VARIOUS QUANTITIES DESCRIBING FLOW AROUND
C AN ELLIPSE.
C
C ARGUMENTS:
C PASSED:
C TMU,TNU . REAL ELLIPTIC COORDINATES OF TOWER
C SMU,SNU REAL ELLIPTIC COORDINATES OF SOURCE
C XSMAJ, YSMAJ REAL CARTESIAN COORDINATES OF SOURCE (M)
C (X-AXIS LIES ALONG MAJOR AXIS)
C RETURNED: NONE
C
C I/O: NONE
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: ABS ATAN COS COSH SIGN SIN SINK SQRT TAN TANK
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: CONST PARAMS -PASVAL PASW VARS
C
C
INCLUDE ' PARAMS . INC '
INCLUDE ' CONST. CMN'
INCLUDE 'PARAMS. CMN'
INCLUDE ' PASVAL . CMN '
INCLUDE 'PASW. CMN'
INCLUDE ' VARS . CMN '
C
C DEFINE ARGUMENTS
REAL TMU, TNU, SMU, SNU, XSMAJ, YSMAJ
C
C DEFINE LOCAL VARIABLES
REAL ABSALF, ANG, CAL, CB, CHECK, CTMU,
* CTNU, DUM1, DUM2, SAL, SB, SDUM, SFAC,
* SNUAL, SSMU, SSNU, SSNUAL, SSRC, STMU, STNU,
* TALPHA, TDUM, TPHIT, TSMU, TTMU, TTNU
C
AXRAT-AAXW/BAXW
TTNU-TAN(TNU)
TTMU-TANH(TMO)
CTNU-COS (TNU)
CTMU-COSH(TMU)
STNU-SIN(TNU)
STMU-SINH(TMU)
TSMU-TANH(SMU)
SSNU-SIN(SNU)
SSMU-SINH(SMU)
DUM1-TTNU/CTMU**2
DUM2-TTMU/CTNU**2
C ANG IS WIND DIR. (AT TOWER) REL. TO MAJOR AXIS; RANGE -180 TO 180
ANG-THTAH-THTA
IF (ANG .LT. -180.) ANG-ANG+360.
IF (ANG .GT. 180.) ANG-ANG-360.
ANG-ANG*DTOR
WRI00010
WRI00030
WRI00040
WRI00050
WRI00060
WRI00070
WRI00080
WRI00090
WRI00100
WRI00110
WRI00120
WRI00130
WRI00140
WRI00150
WRI00160
WRI00170
WRI00180
WRI00190
WRI00200
WRI00210
WRI00220
WRI00230
WRI00240
WRI00250
WRI00270
WRI00280
WRI00290
WRI00300
WRI00310
WRI00320
WRI00330
WRI00340-
WRI00350
WRI00360
WRI00370
WRI00380
WRI00390
WRI00400
WRI00410
WRI00420
WRI00430
WRI00440
WRI00450
WRI00460
WRI00470
WRI00480
WRI00490
WRI00500
WRI00510
WRI00520
WRI00530
WRI00540
WRI00550
WRI00560
WRI00570
WRI00580
WRI00590
WRI00600
tit
127
-------
C FIND TANGENT OF WIND DIR MEAS AT TOWER RELATIVE TO MAJOR AXIS (CCW) WRI00610
TPHIT-TAN(ANG) WRI00620
C FIND ALPHAW (SEE BATCHELOR FOR CONVENTIONS) EQN. A-50 WRI00630
TANUM - (DUM1+TPHIT*DUM2)/AXRAT+(TTNU**2+TTMU**2)*TPHIT WRI00640
TADEN - (l.+(TTMU*TTNU)**2)/AXRAT+DUM2+TPHIT*DUMl WRI00650
IF(TADEN .NE. 0.0) THEN WRI00660
TALPHA - -TANUM/TADEN WRI00670
ALPHAW.- ATAN(TALPHA) WRI00680
ELSE WRI00690
ALPHAW - PIBY2 WRI00700
ENDIF WRI00710
C MAKE SURE THAT DOT PRODUCT OF VECTORS ALONG ANG AND -ALPHAW IS POS. WRI00720
CHECK-COS (ANG) *COS (-ALPHAW) -(-SIN (ANG) *SIN (-ALPHAW) WRI00730
IF(CHECK .LT. 0.) ALPHAW-ALPHAW-SIGN(PI,ALPHAW) WRI00740
C FIND SPEED AT INFINITY (SINF) EQN. A-51 WRI00750
10 STNUAL-SIN(TNU+ALPHAW) WRI00760
TDUM-( (AXRAT**2-1.) *STNU**2+1. )/STMU**2+AXRAT**2+l.+2 . *AXRAT/TTMU WRI00770
TDUM-TDUM/(1.+(STNUAL/STMU)**2) WRI00780
SINF-UV*SQRT(TDUM)/(AXRAT-i-l.) WRI00790
C FIND SPEED AT THE SOURCE WRI00800
SNUAL-SNU+ALPHAW WRICI0810
IF(ABS(SNUAL) .GT. PI) SNUAL-SNUAL-SIGN(TWOPI,SNUAL) WRI00820
SSNUAL-SIN(SNUAL) WRI00830
SDUM-((AXRAT**2-1.)*SSNU**2+1.)/SSMU**2+AXRAT**2+1.+2.*AXRAT/TSMU WRI00840
SDUM-(1.+(SSNUAL/SSMU)**2)/SDUM WRI00850
SSRC-UV*SQRT(SDUM*TDUM) WRI00860
C FIND VALUE OF STREAMFCN THROUGH SOURCE (PSIHAT-PSI/(SINF(AAXW-t-BAXW) ) WRI00870
C EQN. A-52 WRI00880
PSIHAT--SSMU*SSNUAL WRI00890
C APPROX. DISTANCE BETWEEN PSI AND STAGNATION STREAMLINE NEAR SOURCE WRI00900
D-ABS(PSIHAT*(AAXW+BAXW)*SINF/SSRC) WRI00910
C FIND BETA EQN. A-54 WRIQ0920
ABSALF-ABS(ALPHAW) WRI00930
BETA—ALPHAW WRI0 0 9 443-
IF(ABS(ABSALF-PIBY2) .GT. SMALL .AND. ABS(ABSALF-PI) .GT. SMALL WRI00950
* .AND. ABSALF .GT. SMALL) THEN WRI00960
BETA-ATAN(-AXRAT*TAN(ALPHAW)) WRIO 0970
CHECK-COS(-ALPHAW)*COS(BETA)+SIN(-ALPHAW)*SIN(BETA) WRI00980
IF(CHECK .LT. 0.) BETA-BETA-SIGN(PI,BETA) WRI00990
ENDIF WRIO1000
CAL-COS(ALPHAW) . WRI01010
SAL-SIN(ALPHAW) WRI01020
CB-COS(BETA) WRI01030
SB-SIN(BETA) WRI01040
C PROJECT SPEEDS AT INFINITY, SOURCE, AND TOWER ONTO THE BETA-LINE WRI01050
SFAC - -1.0 / COS(ANG-BETA) WRI01060
SINFBE-SINF*SFAC WRI01070
UVBETA-UV*SFAC WRI01080
C FIND THE X-BETA COORD OF THE STAG. PT. AND THE SOURCE WRI01090
XOBETA-AAXW*CAL*CB-BAXW*SAL*SB WRI01100
XSBETA-XSMAJ*CB+YSMAJ*SB WRI01110
C CALCULATE THE DISTANCE TO THE IMPINGEMENT POINT WRI01120
SOBETA-XOBETA-XSBETA WRI01130
SO - SOBETA / SFAC WRI01140
RETURN WRI01150
END WRI01160
i a
128
-------
SUBROUTINE WRITIT(TIME, CONG, NREC, IOCONC)
C SUBROUTINE: WRITIT
C
C PURPOSE: WRITE HOURLY CONCENTRATIONS TO DISK FILE.
C
C ASSUMPTIONS: SWITCH ICONC IN "PARAMS.CMN" CONTROLS THE OUTPUT FORMAT.
C
C ARGUMENTS:
C PASSED:
C TIME INT ARRAY OF LENGTH 4 CONTAINING YEAR, MONTH,
C DAY, AND HOUR INFORMATION
C CONG REAL ARRAY OF MODELED CONCENTRATIONS FOR THIS HOUR
C NREC INT NUMBER CF RECEPTORS
C IOCONC INT UNIT NUMBER USED FOR OUTPUT OF CONCENTRATIONS
C
C RETURNED: NONE
C
C I/O:
C INPUT: NONE
C
C OUTPUT UNIT-IOCONC ARRAYS MET AND CONC (FOR NREC RECEPTORS)
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNALS: NONE
C
C INCLUDE FILES: PARAMS.INC
C
C COMMON BLOCKS: PARAMS.CMN RECEPT.CMN
C
WRT00010
»WT3'pnr\no f\
~nKi UUUi U
WRT00030
WRT00040
WRT00050
WRT00060
WRT00070
WRT00080
WRT00090
WRT00100
WRT00110
WRT00120
WRT00130
WRT00140
WRT00150
WRT00160
WRT00170
WRT00180
WRT00190
WRT00200
WRT00210
WRT00220
WRT00230
WRT00240
WRT00250
WRT00260
WRT00270
WRT00280
WRT00290
WRT00300
WRT00310
-wrnm^n
INCLUDE 'PARAMS.INC1
INCLUDE 'PARAMS.CMN'
INCLUDE 'RECEPT.CMN'
C DEFINE ARGUMENTS, LOCAL VARIABLES
INTEGER NREC, IOCONC
REAL CONC(NREC)
INTEGER*2 TIME(4)
INTEGER NR
C TEST ON SWITCH
IF(ICONC .EQ. 1) THEN
C BINARY OUTPUT FILE
WRITE(IOCONC) TIME, CONC
ELSE IF(ICONC .EQ. 2) THEN
C TEXT FILE, CONCENTRATIONS ONLY
WRITE(IOCONC,61) TIME,NREC
WRITE(IOCONC,62) CONC
ELSE
C TEXT FILE, RECEPTOR INFO PLUS CONCENTRATIONS
IF(ICONC .LT. 0) THEN
C FIRST TIME THROUGH WRITE HEADER
ICONC - IABS(ICONC)
WRITE(IOCONC,64) NREC
DO 110 NR-1,NREC
WRITE(IOCONC,65) NR, (RECPT(I,NR),1-1,4),
110 CONTINUE
ENDIF
WRITE(IOCONC,61) TIME,NREC
WRT00330
WRT00340-
WRT00350
WRT00360
WRT00370
WRT00380
WRT00390
WRT00400
WRT00410
WRT00420
WRT00430
WRT00440
WRT00450
WRT00460
WRT00470
WRT00480
WRT00490
WRT00500
WRT00510
WRT00520
WRT00530
WRT00540
WRT00550
WRT00560
NRHILL(NR)WRT00570
WRT00580
WRT00590
WRT00600
129
-------
120
C
61
62
63
64
65
DO 120 NR=1, NREC
WRITE(IOCONC,63) NR, CONG(MR)
CONTINUE
ENDIF
RETURN
FORMAT(615)
FORMAT(8E10.3)
FORMAT(I4, IX, E10.4)
FORMAT(15)
FORMAT(I4,1X,F8.0,1X,F8.0,1X,F7.1,1X,F6.1,1X,I4)
END
WRT00610
WRT00620
WRT00630
WRT00640
WRT00650
WRT00660
WRT00670
WRT00680
WRT00690
WRT00700
WRT00710
WRT00720
li
130
-------
REAL FUNCTION XINTRP( XI, X2 , X, Yl, Y2 )
C FUNCTION: XINTRP
C
C PURPOSE: THIS FUNCTION LINEARLY INTERPOLATES BETWEEN TWO POINTS
C (Y1,Y2) GIVEN THREE OTHER POINTS (X1,X2,X) WHERE
C XI AND X2 ARE ENDPOINTS AND X IS BETWEEN XI AND X2
C
C ASSUMPTIONS: X IS BETWEEN XI AND X2
C
C REMARKS: IF XI - X2 THEN THE MIDPOINT BETWEEN Yl AND Y2 IS RETURNED
C
C ARGUMENTS:
C PASSED:
C XI, X2 REAL ENDPOINTS OF FIRST LINE
C X REAL POINT BETWEEN XI AND X2
C Y1,Y2 REAL ENDPOINTS OF LINE TO BE INTERPOLATED
C
C FUNCTION VALUE:
C XINTER REAL INTERPOLATED VALUE BETWEEN Yl AND Y2
C
C CALLING ROUTINES: SEQMOD
C
C EXTERNAL ROUTINES: NONE
C
C INTRINSIC FUNCTIONS: NONE
C
C COMMON BLOCKS: NONE
C
C
C DEFINE ARGUMENTS
REAL XI, X2, X, Yl, Y2
C DEFINE LOCAL VARIABLES
REAL OX
C START
DX - X2 - XI
IF( OX .ME. 0.0 ) THEN
XINTRP - Yl + (Y2-Y1) * (X-X1)/DX
ELSE
XINTRP - (Y1+Y2) * 0.5
ENDIF
RETURN
END
XTR00010
XTR00030
XTR00040
XTR00050
XTR00060
XTR00070
XTR00080
XTR00090
XTR00100
XTR00110
XTR00120
XTR00130
XTR00140
XTR00150
XTR00160
XTR00170
XTR00180
XTR00190
XTR00200
XTR00210
XTR00220
XTR00230
XTR00240
XTR00250
XTR00260
XTR00270
XTR00280
XTR00290
• «•••— kjkj» _ _ _
XTR00310
XTR00320
XTR00330
XTR0034&-
XTR00350
XTR00360
XTR00370
XTR00380
XTR00390
XTR00400
XTR00410
XTR00420
XTR00430
XTR00440
tit
131
-------
CTDM INCLUDE Files
132
-------
PARAMETER( MAXLIN = 57)
PARAMETER( MAXHIL = 35)
PARAMETER( MAXZ = 21)
PARAMETER( MAXSOR = 60)
PARAMETER( MXDPTS = 25)
PARAMETER^ MAXREC = 400)
PARAMETER( MAXLEV = 50)
PARAMETER( MAXTOP = 4)
C
C MAXLIN MAXIMUM NUMBER OF PRINTED LINES PER PAGE (HEAD.CMN)
C MAXHIL MAXIMUM NUMBER OF HILLS (HILL.CMN)
C MAXZ MAX NUMBER OF HILL HEIGHT CONTOURS (HILL.CMN)
C MAXSOR MAXIMUM NUMBER OF SOURCES (STACKS.CMN)
C MXDPTS MAX NUMBER OF DOWNWIND GRID POINTS (PASL.CMN)
C MAXREC MAX NUMBER OF RECEPTORS (RECEPT.CMN)
C MAXLEV MAX NUMBER OF MET DATA LEVELS (PROFIL.CMN)
C MAXTOP MAX NUMBER TOP CONCENTRATIONS AT EACH RECEPTOR (TOP.CMN)
C
C
133
-------
c
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
c
REAL PI,
1 DTOR,
COMMON/ CONST/ PI,
1 DTOR,
PIBY2, TWOPI, SQRPI, SQR2 , SQR2PI,
ALPHA, SMALL
PIBY2, TWOPI, SQRPI, SQR2, SQR2PI,
ALPHA, SMALL
DEFINITIONS:
PI (J. 14159)
PIBY2 PI/2
TWOPI 2*PI
SQRPI SQUARE ROOT PI
SQR2 SQUARE ROOT 2
SQR2PI SQUARE ROOT 2*PI
DTOR DEGREES-TO-RADIANS FACTOR
ALPHA FACTOR FOR CONVERTING LENGTH SCALE AT HALF THE HILL
HEIGHT TO LENGTH SCALE OF THE HILL-SHAPE FUNCTION
SMALL USED TO SIGNIFY WHEN A COMPUTED DIFFERENCE IS
CONSIDERED "ZERO"
l3e>
134
-------
c
c
c
INTEGER • NPAGE, NLINES, TITLE(20)
COMMON/ HEAD/ NPAGE, NLINES, TITLE
C
C DEFINITIONS:
C NPAGE INT CURRENT PAGE NUMBER IN PRINTOUT
C NLINES INT NUMBER OF USED LINES ON CURRENT PAGE
C TITLE INT 80 CHARACTER PAGE HEADER
C
C
C
135
-------
c
c-
c
REAL
INTEGER
COMMON/ HILL /
MAJORW, MAJAXW, MINAXW, MAJORL, ZHS, THS, ZOH,
XHW, YHW, XHL, YHL, EXPOMA, EXPOMI,
SCALMA, SCALMI
HILNAM
NHILLS, HILNAM(10,MAXHIL), NZH(MAXHIL)
ZHS(MAXZ,MAXHIL),
XHW(MAXZ,MAXHIL)
CUTOFF HILL
FOR EACH HILL
THS(MAXHIL), ZOH(MAXHIL)
YHW(MAXZ,MAXHIL),
MAJORW(MAXZ,MAXHIL),
* MAJAXW(MAXZ,MAXHIL), MINAXW(MAXZ,MAXHIL),
* XHL(MAXZ,MAXHIL), YHL(MAXZ,MAXHIL),
* MAJORL(MAXZ,MAXHIL),
* EXPOMA(MAXZ,MAXHIL), EXPOMI(MAXZ,MAXHIL),
* SCALMA(MAXZ,MAXHIL), SCALMI(MAXZ,MAXHIL)
DEFINITIONS
GENERAL VARIABLES:
NHILLS - NUMBER OF HILLS (MAX-MAXHIL)
HILNAM - NAME OF HILL (40 CHARACTER MAX)
NZH - NUMBER OF HEIGHTS FOR WHICH ELLIPSE AND
SHAPE VARIABLES ARE PROVIDED, SPECIFIED
ZHS - HEIGHTS FOR WHICH ELLIPSE AND CUTOFF HILL SHAPE
VARIABLES ARE PROVIDED, METERS ABOVE STACK BASE
THS - HEIGHT OF TOP OF HILL ABOVE STACK BASE, METERS
ZOH - SURFACE ROUGHNESS LENGTH OF HILL
VARIABLES FOR WRAP:
XHW - X-COORDINATE OF CENTER OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
YHW - Y-COORDINATE OF CENTER OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
MAJORW - ORIENTATION .OF MAJOR AXIS OF ELLIPTICAL
SPECIFIC VALUE OF ZH, DEGREES CLOCKWISE
MAJAXW - LENGTH OF MAJOR SEMI-AXIS OF ELLIPTICAL
SPECIFIC VALUE OF ZH, METERS
MINAXW - LENGTH OF MINOR SEMI-AXIS OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
CONTOUR FOR A
FROM NORTH
CONTOUR FOR A
VARIABLES FOR LIFT:
XHL
YHL
MAJORL
EXPOMA
EXPOMI
SCALMA
SCALMI
X-COORDINATE OF CENTER OF THE CUTOFF HILL.FOR A
SPECIFIC VALUE OF ZH, METERS
Y-COORDINATE OF CENTER OF THE CUTOFF HILL FOR A
SPECIFIC VALUE OF ZH, METERS
ORIENTATION OF MAJOR AXIS OF THE CUTOFF HILL FOR A
SPECIFIC VALUE OF ZH, DEGREES CLOCKWISE FROM NORTH
EXPONENT IN INVERSE POLYNOMIAL REPRESENTATION OF
CUTOFF HILL SHAPE FUNCTION FOR MAJOR AXIS CROSS SECTION
EXPONENT IN INVERSE POLYNOMIAL REPRESENTATION OF
CUTOFF HILL SHAPE FUNCTION FOR MINOR AXIS CROSS SECTION
SCALE LENGTH (M) IN INVERSE POLYNOMIAL EQUATION FOR
CUTOFF HILL SHAPE FUNCTION FOR MAJOR AXIS CROSS SECTION
SCALE LENGTH (M) IN INVERSE POLYNOMIAL EQUATION FOR
CUTOFF HILL SHAPE FUNCTION FOR MINOR AXIS CROSS SECTION
13"*
136
-------
c-
c
COMMON/ IO/ IN, TOUT, INREC, INEMIS, INSFC,
INPROF, IOCONC, INTERR
C VARIABLES:
C
C
C
C
C
C
C
C
C
C-
IN
IOUT
INREC
INEMIS
INSFC
INPROF
IOCONC
IOTERR
INT UNIT NUMBER OF OPTIONS INPUT FILE
INT UNIT NUMBER OF OUTPUT LISTING FILE
INT UNIT NUMBER OF VARIABLE RECEPTOR INPUT FILE
INT UNIT NUMBER OF VARIABLE EMISSIONS INPUT FILE
INT UNIT NUMBER OF SURFACE METEOROLOGY INPUT FILE
INT UNIT NUMBER OF PROFILE METEOROLOGY INPUT FILE
INT UNIT NUMBER OF BINARY CONCENTRATION OUTPUT FILE
INT UNIT NUMBER OF TERRAIN DATA FILE
13
137
-------
c
c-
c
REAL HORIZ, VERT, ALAT, ALONG, TZONE, CORIOL
INTEGER ICASE, ITOPN, ICONC, IEMIS, IMIX, IWS1,
& ISIGV, IWD, ICHIQ, IPOL
COMMON/ PARAMS/ ICASE, ITOPN, ICONC, IEMIS,
* _ IMIX, IWS1, ISIGV, IWD,
* . ICHIQ, HORIZ, VERT, ALAT,
* ALONG, TZONE, IPOL, CORIOL
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
SWITCHES
ICASE
ITOPN
ICONC
IEMIS
IMIX
IWS1
ISIGV
IWD
ICHIQ
*
(0=NO,
INT
INT
INT
INT
INT
INT
INT
INT
INT
1-YES) :
CASE-STUDY PRINTOUT
CREATE TOP N TABLE
CONCENTRATION OUTPUT (NONE, BINARY, OR
VARIABLE EMISSIONS DATA
ON-SITE MIXING HEIGHTS
SET WIND SPEEDS < 1.0 TO 1.0
USE OBSERVED SIGMA-V DATA
SCALE INPUT WIND DIRECTION WITH HEIGHT
OUTPUT CHI OR CHI/Q (0/1)
TEXT)
VARIABLES :
HORIZ
REAL
CONVERSION FACTOR FROM USER HORIZONTAL
UNITS
TO METERS (E.G., IF KM INPUT FOR X,Y
VERT
ALAT
ALONG
TZONE
IPOL
CORIOL
REAL
REAL
REAL
REAL
INT
REAL
THEN HORIZ - 1000.)
CONVERSION FACTOR FROM USER VERTICAL UNITS TO
METERS (E.G., IF FT INPUT FOR
THEN VERT - 0.3048)
LATITUDE (DEC)
LONGITUDE (DEC)
TIME ZONE CORRECTION FROM GMT (EG. FOR
POLLUTANT # FOR HOURLY EMISSIONS (1-4)
CORIOLIS PARAMETER
ELEVATION
EST 5)
138
-------
c-
c
DIMENSION SG(MXDPTS),ATZSQ(MXDPTS),ATYSQ(MXDPTS)
REAL*4 LX,LY
COMMON /PASL/ PHIM, PHIHL, TNEUT, TSTRAT,
1 XSEPL, YSEPL, XEPL, YEPL,
2 ZMASS, DELTAX, SG, ATZSQ, ATYSQ,
3 LX, LY, GAM, HH, AAXL, BAXL
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C-
DEFINITIONS:
PHIM (RADIANS)
PHIHL (RADIANS)
TNEUT (1/S)
TSTRAT (1/S)
XSEPL,YSEPL (M)
XEPL,YEPL (M)
ZMASS (M)
DELTAX (M)
SG (M)
ATZSQ
ATYSQ
LX
LY
GAM
HH
AAXL
BAXL
MEAN FLOW DIRECTION (CCW FROM N)
ORIENTATION OF MAJOR AXIS OF HILL (CCW FROM N)
I/NEUTRAL LAGPJUJGIAN TIME SCALE
I/STRATIFIED LAGRANGIAN TIME SCALE
SAME AS (XRE,YRE) BUT X-AXIS POINTS ALONG FLOW
SAME AS (XE,YE) BUT X-AXIS POINTS ALONG FLOW
HEIGHT OF CENTER OF MASS OF PLUME ABOVE HC
SPACING BETWEEN GRID POINTS FOR TY,TZ ALONG PATH
DISTANCES TO GRID POINTS ALONG PATH
TZ**2 VALUES AT GRID POINTS
TY**2 VALUES AT GRID POINTS
LENGTH SCALE OF HILL IN THE X-DIRECTION
LENGTH SCALE OF HILL IN THE Y-DIRECTION
ROTATION TERM WITH UNITS M**-2
HEIGHT OF HILL AT THE CREST (THE CUT-OFF HILL)
LENGTH OF MAJOR AXIS OF LIFT HILL METERS
LENGTH OF MINOR AXIS OF LIFT HILL METERS
139
-------
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-
COMMON/ PASVAL / C, TTLZ, TTLY, SO, ZTV, YTV,
* XEL, YEL, XEW, YEW,
* Z, ZELEV, TFAC, SZTEST, ZOHILL, HMIX,
* PHI, PHIC, XS, YS, XR, YR
DEFINITIONS
C(US/M**3>
TTLZ (S)
TTLY (S)
SO (M)
ZTV,YTV (M)
XE,YE,Z (M)
ZELEV (M)
TFAC
SZTEST (M)
ZOHILL(M)
HMIX (M)
PHI, PHIC (RAD)
XS,YS (M)
XR,YR (M)
COMPUTED CONCENTRATION—CHI/Q
LAGRANGIAN TIME SCALE OF THE TRANSVERSE
CORRELOGRAM FOR VERTICAL FLUCTUATIONS
LAGRANGIAN TIME SCALE OF THE TRANSVERSE
CORRELOGRAM FOR HORIZONTAL FLUCTUATIONS
DISTANCE TO IMPINGEMENT POINT ALONG MEAN FLOW
VIRTUAL TRAVEL-TIME TO SIMULATE SOURCE-ENHANCED
PLUME SIZE
RECEPTOR COORDINATES RELATIVE TO HILL CENTER;
HEIGHT ABOVE STACK BASE
RECEPTOR ELEVATION ABOVE THE GROUND
RATIO OF TIME-OF-TRAVEL TO IMPINGEMENT IN WRAP
TO THAT IN LIFT
SIGMA-Z AT IMPINGEMENT
ROUGHNESS LENGTH OF HILL
DEPTH OF MIXED LAYER ABOVE HC
ANGLES (CCW FROM N) TO SOURCE AND HILL CENTER
SOURCE COORDINATES IN USER'S GRID (X POINTS E)
RECEPTOR COORDINATES IN USER'S GRID (X POINTS E)
(34
140
-------
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-
COMMON/ PASW / ALPHAW, BETA, PSIHAT, AAXW, BAXW, AXRAT,
* SIGNYE, XRBETA, XSBETA, XOBETA, UVBETA,
* SINF, SINFBE, D, SOBETA, THTAH
DEFINITIONS
ALPHAW(RADIANS)
BETA (RADIANS)
PSIHAT
AAXW,BAXW (M)
AXRAT
SIGNYE
XRBETA (M)
XSBETA (M)
XOBETA (M)
UVBETA (M/S)
SINF (M/S)
SINFBE (M/S)
D (M)
SOBETA (M)
THTAH (DEC)
WIND DIRECTION FAR FROM HILL, MEASURED CLOCKWISE
FROM MAJOR AXIS OF HILL
WIND DIRECTION AT IMPINGEMENT POINT, MEASURED
COUNTERCLOCKWISE FROM THE MAJOR AXIS OF HILL
STREAM FUNCTION THROUGH SOURCE/(SINF(AAX+BAX)
SEMI-MAJOR AXIS, SEMI-MINOR AXIS OF HILL
RATIO AAX/BAX
SIGN DESIGNATING WHETHER SOURCE AND RECEPTOR
ARE ON SAME SIDE (+) OR OPPOSITE SIDE (-) OF
STAGNATION STREAMLINE
POSITION OF RECEPTOR ALONG THE "BETA AXIS"
POSITION OF SOURCE ALONG THE "BETA AXIS"
POSITION OF IMPINGEMENT POINT ALONG THE
"BETA AXIS"
SPEED AT SOURCE PROJECTED ALONG THE "BETA AXIS"
SPEED AT INFINITY
SPEED AT INFINITY PROJECTED ALONG THE
"BETA AXIS"
APPROXIMATE DISTANCE BETWEEN SOURCE AND
STAGNATION STREAMLINE
DISTANCE TO IMPINGEMENT POINT ALONG "BETA AXIS"
ORIENTATION OF MAJOR AXIS OF HILL
141
-------
c-
c
1
2
REAL
COMMON/PROFIL/
WDHR(MAXLEV),
SVHR(MAXLEV),
HT(MAXLEV)
WDHR, WSHR,
HT, NHT
WSHR(MAXLEV),
SWHR(MAXLEV),
UVHR(MAXLEV),
TAHR(MAXLEV),
UVHR, SVHR, 3WHR, TAHR,
c
C VARIABLES:
C
C
C
C
C
C
C
C
C
C
C
C
WDHR
WSHR
UVHR
SVHR
SWHR
TAHR
HT
NHT
REAL
-
REAL
REAL
REAL
REAL
REAL
REAL
INT
ARRAY
ARRAY
ARRAY
ARRAY
ARRAY
ARRAY
ARRAY
OF WIND DIRECTIONS (DEC) AT MULTIPLE
HEIGHTS
OF SCALAR WIND SPEEDS (M/S) AT MULT. HTS
OF VECTOR WIND SPEEDS (M/S) AT MULT. HTS
OF SIGMA-V'S (DEC) AT MULTIPLE HEIGHTS
OF SIGMA-W'S (M/S) AT MULTIPLE HEIGHTS
OF AMBIENT TEMPERATURES (DEC K) AT
MULTIPLE HEIGHTS
OF HEIGHTS (M) FOR ABOVE PARAMETERS.
NEGATIVE HEIGHTS INDICATE NO MORE DATA
NUMBER OF LEVELS OF DATA
142
-------
c
c
c
REAL
INTEGER
COMMON/
C
C DEFINITIONS:
C
C
C
c
c
c
c
c
c
c
c
c-
c
NRECPT
RNAME
RECPT
NRHILL
NRFLAT
RECPT(4,MAXREC)
NRECPT, RNAME(4,MAXREC) , NRHILL(MAXREC), NRFLAT
RECEPT/ NRECPT, RNAME, RECPT, NRHILL, NRFLAT
INT NUMBER OF RECEPTORS
INT ARRAY OF RECEPTOR NAMES
REAL ARRAY OF RECEPTOR INFORMATION
RECPT(1,N) X COORDINATE (M)
RECPT(2,N) Y COORDINATE (M)
RECPT(3,N) HEIGHT ABOVE GROUND (M)
RECPT(4,N) GROUND ELEVATION (M)
INT HILL NUMBER THIS RECEPTOR IS ON
INT FLAG INDICATING IF THERE ARE RECEPTORS ASSIGNED
TO HILL NUMBER 0 (FLAT TERRAIN)
143
-------
c-
c
COMMON/ SFCMET/ IYR,
TA,
IMO, IDY,
USTARO, EL,
JCD, IHR,
WSTAR, ZO
XMH,
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
VARIABLES :
IYR
IMO
IDY
JCD
IHR
XMH
TA
USTARO
EL
WSTAR
ZO
INT
INT
INT
INT
INT
REAL
REAL
REAL
REAL
REAL
REAL
YEAR
MONTH
DAY
JULIAN DAY
HOUR
MIXING DEPTH (M)
SURFACE TEMPERATURE (K)
FRICTION VELOCITY (M/S)
MONIN-OBUKHOV LENGTH (M)
VERTICAL SCALING VELOCITY (M/S)
SURFACE ROUGHNESS LENGTH
14 A
-------
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
COMMON/ STACK/
HS,
FM
DS,
vs,
TS,
HB,
FB,
CURRENT STACK PARAMETERS
HS REAL STACK HEIGHT (M)
DS REAL STACK DIAMETER (M)
VS REAL STACK GAS EXIT VELOCITY (M/S)
TS REAL STACK GAS TEMPERATURE (DEG-K)
HB REAL BUILDING HEIGHT (M)
FB REAL BUOYANCY FLUX PORTION (M**4/S**3)
(G*VS*DS*DS/4)
FM REAL MOMENTUM FLUX PORTION (M**4/S**2)
(VS*VS*DS*DS/4)
145
-------
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
REAL SOURCE(11,MAXSOR)
INTEGER IVAR(MAXSOR)
COMMON/ STACKS/ NSTACK, SOURCE, KEMIS,
IVAR
DEFINITIONS:
NSTACK INT
SOURCE REAL
NUMBER OF SOURCES THIS RUN
ARRAY OF SOURCE PARAMETERS
KEMIS
IVAR
INT
INT
SOURCE(1,N)
SOURCE(2,N)
SOURCE(3,N)
SOURCE(4,N)
SOURCE(5,N)
SOURCE(6,N)
SOURCE(7,N)
SOURCE(8,N)
SOURCE(9,N)
SOURCE(10,N)
SOURCE(11,N)
X-COORDINATE (M)
Y-COORDINATE (M)
Z-COORDINATE (M)
STACK HEIGHT (M)
STACK DIAMETER (M)
STACK GAS TEMPERATURE (DEG-K)
STACK GAS EXIT VELOCITY (M/S)
EMISSION RATE (G/S)
ASSOCIATED BUILDING HEIGHT (M)
USED FOR DOWNWASH CONDITIONS
BUOY. FLUX PORTION: G*VS*DS*DS/4
MOM. FLUX PORTION: VS*VS*DS*DS/4
NUMBER OF SOURCES WITH HOURLY EMISSIONS
ARRAY OF FLAGS FOR SOURCES WITH HOURLY EMISSIONS
146
-------
c
c
c
c
c
c
c
c
c
c
c
c
r —
COMMON/
1
CURRENT
TSR
TSS
KYR
KMO
KDY
KHR
KJCD
TIME/
TIME
REAL
REAL
INT
INT
INT
INT
INT
TSR,
KJCD
VARIABLES :
TIME OF
TIME OF
CURRENT
CURRENT
CURRENT
CURRENT
JULIAN
TSS, KYR, KMO, KDY, KHR,
SUNRISE
SUNSET
YEAR
MONTH
DAY OF MONTH
HOUR (1-24)
CALENDAR DATE
147
-------
^-
c
c
c
c
c
c
c
c
c
REAL
INTEGER
COMMON/
DEFINITIONS :
CTOP
TOPTIM
TOPTOP
TOP/
REAL
_
INT
REAL
CTOP (MAXTOP, MAXREC) , TOPTOP (MAXTOP)
TOPTIM (MAXTOP, MAXREC)
CTOP, TOPTIM, TOPTOP
ARRAY CONTAINING TOP MAXTOP CONCENTRATIONS
AT EACH RECEPTOR
ARRAY CONTAINING JCD AND HOUR FOR TOP
CONCENTRATIONS IN CTOP
ARRAY CONTAINING TOP MAXTOP OVERALL
148
-------
c
c-
c
c
c
c
c
c
c
c
c-
c
REAL XT, YT, ZT, BASEHT
COMMON/ TOWER/ XT, YT, ZT, BASEHT
VARIABLES:
XT REAL
YT SEAL
ZT REAL
BASEHT REAL
X COORDINATE OF TOWER, M
Y COORDINATE OF TOWER, M
TOWER BASE ELEVATION, M
TOWER BASE HEIGHT MINUS STACK BASE HEIGHT, M
iff
149
-------
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
COMMON/ VARS/
DEFINITIONS
HPL (M)
XSZS (M)
SZS (M) -
US (M/S)
UV (M/S) -
THTA (DEC)
SIGV (M/S)
SIGW (M/S)
ALF (1/S)
HC (M)
FR
BRUNT (1/S)
USTKTP (M/S)
KST
NR
HPL, XSZS, SZS, US, UV, THTA, SIGV, SIGW,
ALF, HC, FR, BRUNT, USTKTP, KST, NR
HEIGHT OF PLUME ABOVE STACK BASE
DISTANCE TO FINAL PLUME RISE
SIGMA-Z OF PLUME AT FINAL RISE
SCALAR-AVERAGE WIND SPEED AT PLUME HEIGHT
VECTOR-AVERAGE WIND SPEED AT PLUME HEIGHT
VECTOR-AVERAGE WIND DIRECTION AT PLUME HEIGHT
SIGMA-V AT PLUME HEIGHT
SIGMA-W AT PLUME HEIGHT
WIND SPEED SHEAR AT PLUME HEIGHT
CRITICAL DIVIDING-STREAMLINE HEIGHT ABOVE STACK BASE
FROUDE NUMBER FOR FLOW ABOVE HC
BRUNT-VAISALA FREQUENCY AT PLUME HEIGHT
WIND SPEED AT STACK TOP
COLDER STABILITY CLASS
CURRENT RECEPTOR NUMBER
150
-------
APPENDIX D
RECEPTOR GENERATOR CODE LISTINGS
1.51
-------
RECGEN Receptor Generator Program
3557F B876-250-B
152
-------
10 *********
20 *********
30 'RECGEN is a program to generate coordinates for CTDM receptors evenly
40 'spaced around the perimeter of unedited digitized contours. The locations
50 'of these receptors are plotted on a display terminal with 320(horizontal)
60 'X200(vertical) resolution in color or 640(horizontal)X200(vertical)
70 'resolution in black and white. For each contour, the user has the option
80 'of specifying whether the spacing of receptors around the perimeter of
90 'the contour is based directly upon an incremental distance value input
100 'by the user or an incremental distance calculated by dividing the total
110 'contour perimeter by a number of points input by the user.
120 *********
130 *********
140 'Clear the screen
150 CLS
160 'Disable the display of function keys to allow more space for plotting.
170 KEY OFF
180 'Define variables beginning with letters I through N as integers.
190 DEFINT I-N
200 'Dimension the arrays for sorted contour identification numbers(from FITCON
210 'and a possible previous run of RECGEN)
220 DIM IDC1(200),IDC2(200)
230 'Dimension arrays holding the receptor spacing along each contour and
240 'the number of receptors along each contour.
250 DIM DL(200),NREC(200)
260 'Set the maximum number of receptors per contour.
270 NRMAX-1000
280 'Define a zero constant.
290 ZERO-Ol
294 'Define format for CTDM receptor file.
295 IFMT$-"\ \ff# flfff.fff fflff.ff* ifflf.ff* ###f#.f## ####"
300 LOCATE 12,15
310 'Input the name of the plot file generated from program FITCON.
320 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
330 'If the specified file does not exist, write a program error message. ~
340 ON ERROR GOTO 3650
350 OPEN PLOT1$ FOR INPUT AS 11
360 'Reset error condition to default.
370 ON ERROR GOTO 0
380 'Make sure that this plot file was generated by program FITCON.
390 INPUTfl, PF1$
400 IF PF1$-"FITCON" THEN GOTO 480
410 'Match not found. User asked to try again.
420 CLS
430 LOCATE 10,15
440 PRINT PLOT1$ " IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN"
450 'Close the file which failed the test.
460 CLOSE II
470 GOTO 300
480 CLS
490 'Input the hill identification number, hill name, hill center coordinates
500 'number of contours, and the identification numbers for the contours.
510 INPUTfl, IDH1,HNAME1$
520 INPUTfl, XHTOP,YHTOP
530 INPUTfl, NCI
540 FOR J-l TO NCI
550 INPUTfl, IDC1(J)
560 NEXT J
570 'Input the plot boundaries for the unedited contours.
580 INPUTfl, XMIN1,XMAX1,YMIN1,YMAX1
153
-------
590 'Input the plot boundaries for the edited contours(not used).
600 INPUTfl, XMIN2,XMAX2,YMIN2,YMAX2
610 LOCATE 10,22
620 'Select the. type of display.
630 PRINT "SELECT TYPE OF DISPLAY"
640 PRINT
650 PRINT TAB(22) »1.) Low resolution with color"
660 PRINT TAB(22) H2.) High resolution black and white"
670 PRINT
680 INPUT " Choice? (1 or 2)—>" ;RFLAG%
690 CLS
700 'Set plot boundaries, scale factors and colors.
710 SCRCX-320!:DSCRX-453!:SCRCY-104!:DSCRY-184!:RATIO-1.3201
720 IF RFLAG%-1 THEN SCRCX-160!:DSCRX-200!:DSCRY-186.:RATIO-1.5900
730 'For the unedited contours, calculate the coordinates of the center
740 'of the display and the horizontal and vertical dimensions of the
750 'display.
751 'Set the radius for the display of receptor points.
752 IF RFLAG*-! THEN IRAD-2 ELSE IRAD-3
760 XC-(XMIN1+XMAX1)/21
770 YC-(YMINl+YMAXl)/2!
780 DX-XMAX1-XMIN1
790 DY-YMAX1-YMIN1
800 IF DX/DY";ANS$
910 IF ANS$-"N" THEN GOTO 1450 —
920 IF ANS$-"n" THEN GOTO 1450
930 CLS
940 LOCATE 12,15
950 'Input the name of the perimeter distance file.
960 INPUT " INPUT NAME OF THE PERIMETER DISTANCE FILE->";PLOT2$
970 'If the file does not exist, then assume that a new file must be generated.
980 ON ERROR GOTO 1350
990 OPEN PLOT2$ FOR INPUT AS 12
1000 'Reset error condition to default.
1010 ON ERROR GOTO 0
1020 'Make sure that this file was generated by program RECGEN by comparing
1030 'the first variable with the character expression "RECGEN". otherwise
1040 'assume that a new file must be generated.
1050 INPUTI2, PF2$
1060 IF PF2$<>"RECGEN" THEN GOTO 1330
1070 INPUTI2, IDH2,HNAME2$
1080 'Determine whether the hill identification number and hill name from
1090 'the contour perimeter distance file agree with the corresponding values
1100 'from the plot file generated by program FITCON. If not, assume that a
1110 'new contour perimeter distance file must be generated.
1120 IF IDH20IDH1 THEN GOTO 1330
1130 IF HNAME1$OHNAME2S THEN GOTO 1330
1140 INPUTI2, NC2
1150 'Determine whether the number of contours from the contour perimeter
1160 'distance file agrees with the corresponding value from the plot file
154
-------
1170 'generated by program FITCON. If not, assume that a new contour perimeter
1180 'file must be generated.
1190 IF NC10NC2 THEN GOTO 1330
1200 'Determine whether the contour identification numbers from the contour
1210 'perimeter distance file agree with the corresponding values from the
1220 "plot file generated by program FITCON. If not, assume that a new contour
1230 'perimeter file must be generated.
1240 FOR J-l TO NC2
1250 INPUT#2, IDC2(J)
1260 IF IDC1(J)<>IDC2(J) THEN GOTO 1330
1270 NEXT J
1280 'Set PERFLG% equal to 1 to indicate that a new contour perimeter
1290 'distance file does not have to be generated. The file specified by the
1300 'user has been accepted.
1310 PERFT6%-1
1320 GOTO 1610
1330 CLS
1340 GOTO 1370
1350 PRINT PLOT2$ " COULD NOT BE OPENED Press any key"
1355 A$-INKEY$:IF A$-"" THEN GOTO 1355
1360 GOTO 1450
1370 LOCATE 10,6
1380 PRINT PLOT2$ " IS NOT A FILE GENERATED BY PROGRAM RECGEN"
1390 PRINT TAB(5) " A NEW PERIMETER DISTANCE FILE WILL BE GENERATED Press any ke
1395 A$-INKBY$:IF A$-lt" THEN GOTO 1395
1400 'Close the file which failed the test as a valid perimeter distance
1410 'file.
1420 CLOSE #2
1430 'Input the name of the new file to be used for contour perimeter
1440 'distances.
1450 CLS
1460 LOCATE 12,15
1470 INPUT " INPUT NAME OF NEW PERIMETER DISTANCE FIL£->";PLOT2$
1480 CLS
1490 'Open a file for storage of contour perimeter distance —
1500 'information.
1510 OPEN PLOT2$ FOR OUTPUT AS #2
1520 'write identifiers to the contour perimeter distance file.
1530 PRINTI2, "RECGEN"
1540 PRINT!2, IDH1,HNAME1$
1550 PRINTI2, NCI
1560 FOR J-l TO NCI
1570 PRINTI2, IDC1(J)
1580 NEXT J
1590 'Input the name of the receptor output file which will be input to
1600 'CTDM
1610 CLS
1620 LOCATE 12,15
1630 INPUT * INPUT NAME OF RECEPTOR OUTPUT FILE->";ROUT$
1640 CLS
1650 'Open the receptor output file.
1660 OPEN ROUT$ FOR OUTPUT AS 13
1670 'For the medium resolution mode, set the background color to light
1680 'blue and the digitized contour color to white.
1690 IF RFLAG*-! THEN SCREEN l:IC-3 ELSE SCREEN 2:IC-1
1700 IF RFLAG%-1 THEN COLOR 9,1
1705 IF RFLAG*-! THEN PALETTE 3,15:PALETTE 2,13
1710 'Begin loop over contours.
1720 FOR J-l TO NCI
1730 'Zero out the total distance traveled along the contour.
155
-------
1740 TPDIS-0!
1750 'Input the number of points on the contour and the contour elevation.
1760 INPUT*1, HPC,HCON
1770 'Write the number of contour points and the contour elevation to the
1780 'contour perimeter distance file.
1790 IF PERFLG%»0 THEN PRINTI2, NPC,HCON
1800 'Input the coordinates of the first contour point.
1810 INPUTfl, XI, Yl
1820 IF PERFLG%-0 THEN PRINTI2, XI,Y1,TPDIS:XB=X1:YB-Y1
1830 XOLD-X1
1840 YOLD-Y1
1850 'Set contour closure indicator to zero. The parameters DUPFLG% and IFR
1860 'are used to allow the plotting of multiple contours at the same
1870 'elevation.
1880 DUPFLG%-0
1890 'Scale first contour point for plotting.
1900 XS1-SCRCX+(X1-XC)*DSCRXDDD
1910 YS1-SCRCY-(Y1-YC)*DSCRYDDD
1920 'Plot the first contour point.
1930 PSET(XS1,YS1),1C
1940 'Set contour closure counter to zero.
1950 IFR-0
1960 'Begin loop over the remainder of the contour points.
1970 FOR K-2 TO NPC
1980 INPUTfl, X,Y
1990 'It 2 or more contour closures have been reached and the point has the
2000 'coordinates as the initial point, then skip over the point for plotting.
2010 IF IFR<2 THEN GOTO 2060
2020 IF ABS(X-X1)>1E-15 OR ABS(Y-Y1)>1E-15 THEN GOTO 2060
2030 IF PERFLG%-0 THEN PRINT#2, X,Y,TPDIS:XB-X:YB-Y
2040 GOTO 2310
2050 'Scale the point X,Y for plotting.
2060 XS-SCRCX+(X-XC)*DSCRXDDD
2070 YS-SCRCY-(Y-YC)*DSCRYDDD
2080 IF DUPFLG%-0 THEN GOTO 2210
2090 'One of the multiple contours has been closed. Move to the new point
2100 'without drawing a line. Substitute the current point for the previous
2110 'individual contour beginning point.
2120 XOLD-X
2130 YOLD-Y
2140 DUPFLG%-0
2150 PSET(XS,YS),IC
2160 IF PERFLG%-0 THEN PRXNTf2, X,Y,TPDIS:XB-X:YB-Y
2170 GOTO 2310
2180 'Determine whether one of the individual multiple contours has been
2190 'closed. If so, set the closure indicator DUPFLG% to 1 and increment
2200 'the contour closure counter IFR by 1.
2210 IF ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG%-1:IFR-IFR+1
2220 'Draw a line from the previous point to the current point.
2230 LINE -(XS,YS),IC
2240 IF PERFLG%<>0 THEN GOTO 2310
2250 DL-SQR((X-XB)A2+(Y-YB)A2+1E-15)
2260 XB-X
2270 YB-Y
2280 TPDIS-TPDIS+DL
2290 PRINTI2, X,Y,TPDIS
2300 'End loop over contour points.
2310 NEXT K
2320 'If toe contour perimeter distance file already exists, then read
2330 'through the file to find to find the total perimenter distance.
156
-------
2340 IF PERFLG%=0 THEN GOTO 2410
2350 INPUT#2, IDUM,DUM
2360 FOR K»l TO NPC-1
2370 INPUTI2, XDUM,YDUM,TPDIS
2380 NEXT K
2390 INPUTI2, XDUM,YDUM,TPDIS
2400 'Skip over edited contour points.
2410 INPUT!1, NPC,HDUM
2420 FOR K-l TO NPC
2430 INPUTtl, DUMX,DUMY
2440 NEXT K
2450 'Determine whether the user wishes to specify receptor spacing for
2460 'contour J directly or wants to have the spacing calculated based upon
2470 'a user specified number of evenly spaced points along the contour.
2480 LOCATE 1,1
2490 INPUT "METHOD: 1)DL OR 2)N? (1 or 2)->";RMETH%
2500 LOCATE 1,1:PRINT " "
2510 IF RMETH%<1 OR RMETH*>2 THEN GOTO 2480
2520 IF RMETH%-2 THEN GOTO 2590
2530 LOCATE 1,1
2540 INPUT "DISTANCE INCREMENT->";DL(J)
2550 IF DL(J)<1E-15 THEN GOTO 2530
2560 NREC(J)-INT(TPDIS/DL(J))
2570 IF NREC(J)>NRMAX THEN NREC(J)-NRMAX
2580 GOTO 2670
2590 LOCATE 1,1
2600 INPUT "NUMBER OF RECEPTORS->";NREC(J)
2610 IF NREC(J)>NRMAX THEN NREC(J)-NRMAX
2620 IF NREC(J)-0 THEN GOTO 2650
2630 DL(J)-TPDIS/NREC(J)
2640 GOTO 2670
2650 DL(J)-0!
2660 'End loop over contours
2670 LOCATE 1,1:PRINT " "
2680 NEXT J
2690 'Scale hill center coordinates.
2700 XSHC-SCRCX+(XHTOP-XC)*DSCRXDDD
2710 YSHC-SCRCY-(YHTOP-YC)*DSCRYDDD
2720 XUL-XSHC-1
2730 XLR-XSHC+1
2740 YUL-YSHC-1
2750 YLR-YSHC+1
2760 'Plot a 3X3 box of points centered at the hill center.
2770 LINE(XUL,YUL)-
-------
2940 'Begin Loop over contours to generate receptor points.
2950 FOR J=l TO NCI
2960 'Set the number of digitized contour points read to zero.
2970 NPTS=0
2980 'Set the receptor for the individual contour to I.
2990 NUMR-1
3000 'Read the number of points on the contour and the contour elevation.
3010 INPUTI2, NPC,HCON
3020 'If the number of receptor points is zero, then skip to the next contour.
3030 IF NREC(J)-0 THEN GOTO 3560
3040 'Place a receptor at the first contour point.
3050 INPUTf2, X,Y,PD
3060 'Increment the number of digitized contour points read by 1.
3070 NPTS-NPTS+1
3080 'Save the coordinates of the first point.
3090 XLAST-X:YLAST-Y:PDLAST-PD
3100 'Scale the first receptor point for plotting.
3110 XP-SCRCX+(X-XC)*DSCRXDDD
3120 YP-SCRCY-(Y-YC)*DSCRYDDD
3130 'Plot a circle of radius IRAO with its center at this first receptor point.
3135 'If the center of the circle falls within a previously plotted receptor
3136 'circle, then paint out that portion of the previous circle which falls
3137 'within the new circle.
3138 CIRCLE(XP,YP),IRAO,0
3139 PAINT(XP,YP),0,0
3140 CIRCLE(XP,YP),IRAD,1C
3150 PAINT(XP,YP),IC,IC
3160 'Increment the total receptor number by 1.
3170 NUMRT-NUMRT+1
3180 'Write the coordinates of this point to the CTDM receptor input file.
3190 PRINT#3, USING IFMT$;HNAME1$,NUMRT,X,Y,ZERO,HCON,IDH1
3200 'Increment the contour receptor number by 1.
3210 NUMR-NUKR+1
3220 'Determine whether all receptors have been allocated for this contour.
3230 IF NUMR>NR£C(J) THEN GOTO 3560
3240 'Find the distance(from the first contour point) to the next receptor
3250 'point.
3260 DISTR-(NUMR-1)*DL(J)
3270 'Read the coordinates and running perimeter distance for the next
3280 'digitized contour point unless the receptor perimeter distance is
3290 'less than the current running distance for the current contour point.
3300 IF DISTR<-PD THEN GOTO 3380
3310 XIAST-X:YLAST-Y:PDLAST-PD
3320 INPUT*2, X,Y,PD
3330 NPTS-NPTS+1
3340 'Determine whether this running distance is less than the distance to the
3350 'next receptor point.
3360 IF PIXDISTR THEN GOTO 3310
3370 'Calculate the X,Y coordinates of the receptor point by interpolation.
3380 FACT-(DISTR-PDLAST)/(PD-PDLAST)
3390 XR-FACT*(X-XLAST)+XLAST
3400 YR-FACT*(Y-YLAST)+YLAST
3410 'Scale receptor point XR,YR for plotting.
3420 XP-SCRCX+(XR-XC)*DSCRXDDD
3430 YP"SCRCY-(YR-YC)*DSCRYDDD
3440 'Plot a circle of radius IRAD with its center at XP,YP.
3441 CIRCLE(XP,YP),IRAD,0
3442 PAINT(XP,YP),0,0
3450 CIRCLE(XP,YP),IRAD,1C
3460 PAINT(XP,YP),IC,IC
158
-------
3470 'Increment the total receptor number by 1.
3480 NUMRT-NUMRT+1
3490 'Write th« coordinates of the receptor point to the CTDM receptor file.
3500 PRINT#3, USING IFMTS;HNAME1$,NUMRT,XR,YR,ZERO,HCON,IDH1
3510 'Increment the contour receptor number by 1.
3520 NUMR-NUMR+1
3530 'Determine whether all receptors have been allocated for this contour.
3540 IF NUMR>NREC(J) GOTO 3560
3550 GOTO 3260-
3560 'Read through the remaining digitized contour points.
3570 FOR K-NPTS+1 TO NPC
3580 INPUT#2, DUM1,DUM2,DOM3
3590 NEXT K
3600 NEXT J
3610 LOCATE 1,1
3620 PRINT HNAM£1$ " RECEPTORS "
3630 'Program execution will cease if the user presses any key
3640 A$-INKEY$:IF AS-"" THEN GOTO 3640 ELSE SYSTEM
3650 IF ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUND-Press any key"
3660 A$-INKEY$:IF AS-"" THEN GOTO 3660
3670 SYSTEM
159
-------
HRECGEN Hercules™ VERSION OF RECGElf
160
-------
10 i********
20 '********
30 'RECGEN is a program to generate coordinates for CTDM receptors evenly
40 'spaced around the perimeter of unedited digitized contours. The locations
50 'of these receptors are plotted on a display terminal with 720(horizontal)
60 'X348(vertical) resolution(black and white) driven by a Hercules Graphics
65 'Board. For each contour, the user has the option of specifying whether the
70 'spacing of receptors around the perimeter of the contour is based directly
80 'upon an incremental distance value input by the user or an incremental
90 'distance calculated by dividing the total contour perimeter by a number of
100 'points input by the user.
120 '********
130 '********
140 'clear the screen
150 CLS
160 'Disable the display of function keys to allow more space for plotting.
170 KEY OFF
180 'Define variables beginning with letters I through N as integers.
190 DEFINT I-N
200 'Dimension the arrays for sorted contour identification numbers(from FITCON
210 'and a possible previous run of RECGEN)
220 DIM IDC1(200),IDC2(200)
230 'Dimension arrays holding the receptor spacing along each contour and
240 'the number of receptors along each contour.
250 DIM DL(200),NREC(200)
260 'Set the maximum number of receptors per contour.
270 NRMAX-1000
280 'Define a zero constant.
290 ZERO-0!
294 'Define format for CTDM receptor file.
295 IFMT$-"\ \fff fffff.flf *****.*** #ff#f.### f**#*.fff ####"
300 LOCATE 12,15
310 'Input the name of the plot file generated from program FITCON.
320 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
330 'If the specified file does not exist, write a program error message.
340 ON ERROR GOTO 3650
350 OPEN PLOT1$ FOR INPUT AS II
360 'Reset error condition to default.
370 ON ERROR GOTO 0
380 'Make sure that this plot file was generated by program FITCON.
390 INPUTfl, PF1$
400 IF PF1$-"FITCON" THEN GOTO 480
410 'Match not found. User asked to try again.
420 CLS
430 LOCATE 10,15
440 PRINT PLOT1$ " IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN"
450 'Close the file which failed the test.
460 CLOSE II
470 GOTO 300
480 CLS
490 'Input the hill identification number, hill name, hill center coordinates
500 "number of contours, and the identification numbers for the contours.
510 INPUT*!, IDH1,HKAME1$
520 INPUTfl, XHTOP,YHTOP
530 INPUTfl, NCI
540 FOR J-l TO NCI
550 INPUTfl, IDC1(J)
560 NEXT J
570 'Input the plot boundaries for the unedited contours.
580 INPUTfl, XMIN1,XMAX1,YMIN1,YMAX1
161
-------
590 'Input the plot boundaries for the edited contours(not used).
600 INPUT*1, XMIN2,XMAX2,YMIN2,YMAX2
700 'Set plot boundaries, scale factors and colors.
710 SCRCX*360!:DSCRX-490!:SCRCY=180!:DSCRY=327!:RATIO=1.4653
730 'For the unedited contours, calculate the coordinates of the center
740 'of the display and the horizontal and vertical dimensions of the
750 "display.
751 'Set the radius for the display of receptor points.
752 IRAD-3
760 XO(XMINl+XMAXl)/2!
770 YC=(YMINl+YMAXl)/2!
780 DX-XMAX1-XMIN1
790 DY-YMAX1-YMIN1
800 IF DX/DY";ANS$
910 IF ANS$-"N" THEN GOTO 1450
920 IF ANS$-"n" THEN GOTO 1450
930 CLS
940 LOCATE 12,15
950 'Input the name of the perimeter distance file.
960 INPUT " INPUT NAME OF THE PERIMETER DISTANCE FILE->";PLOT2$
970 'If the file does not exist, then assume that a new file must be generated.
980 ON ERROR GOTO 1350
990 OPEN PLOT2$ FOR INPUT AS 12
1000 'Reset error condition to default.
1010 ON ERROR GOTO 0 __
1020 'Make sure that this file was generated by program RECGEN by comparing
1030 'the first variable with the character expression "RECGEN". otherwise
1040 'assume that a new file must be generated.
1050 INPUTI2, PF2$
1060 IF PF2$o"RECGEN" THEN GOTO 1330
1070 INPUTI2, IDH2,HNAME2$
1080 'Determine whether the hill identification number and hill name from
1090 'the contour perimeter distance file agree with the corresponding values
1100 'from the plot file generated by program FITCON. If not, assume that a
1110 'new contour perimeter distance file must be generated.
1120 IF IDH20IDH1 THEN GOTO 1330
1130 IF HNAME1$<>HNAME2$ THEN GOTO 1330
1140 INPUTI2, NC2
1150 'Determine whether the number of contours from the contour perimeter
1160 'distance file agrees with the corresponding value from the plot file
1170 'generated by program FITCON. If not, assume that a new contour perimeter
1180 'file must be generated.
1190 IF NC10NC2 THEN GOTO 1330
1200 'Determine whether the contour identification numbers from the contour
1210 'perimeter distance file agree with the corresponding values from the
1220 'plot file generated by program FITCON. If not, assume that a new contour
1230 'perimeter file must be generated.
1240 FOR J-l TO NC2
1250 INPUTI2, IDC2(J)
1260 IF IDC1(J)<>IDC2(J) THEN GOTO 1330
162
-------
1270 NEXT J
1280 'Set PERFLG% equal to 1 to indicate that a new contour perimeter
1290 'distance file does not have to be generated. The file specified by the
1300 'user has been accepted.
1310 PERFLG%-1
1320 GOTO 1610
1330 CLS
1340 GOTO 1370
1350 PRINT PLOT2$ " COULD NOT BE OPENED Press any key"
1355 A$-INKEY$:IF AS-"" THEN GOTO 1355
1360 GOTO 1450.
1370 LOCATE 10,6
1380 PRINT PLOT2$ " IS NOT A FILE GENERATED BY PROGRAM RECGEN"
1390 PRINT TAB(5) " A NEW PERIMETER DISTANCE FILE WILL BE GENERATED Press any ke
1395 A$-INKEY$:IF A$-"" THEN GOTO 1395
1400 'Close the file which failed the test as a valid perimeter distance
1410 'file.
1420 CLOSE #2
1430 'Input the name of the new file to be used for contour perimeter
1440 'distances.
1450 CLS
1460 LOCATE 12,15
1470 INPUT " INPUT NAME OF NEW PERIMETER DISTANCE FILE->";PLOT2$
1480 CLS
1490 'Open a file for storage of contour perimeter distance
1500 'information.
1510 OPEN PLOT2$ FOR OUTPUT AS 12
1520 'Write identifiers to the contour perimeter distance file.
1530 PRINTI2, "RECGEN"
1540 PRINT*2, IDH1,HNAME1$
1550 PRINTI2, NCI
1560 FOR J-l TO NCI
1570 PRINT#2, IDC1(J)
1580 NEXT J
1590 'Input the name of the receptor output file which will be input to _
1600 'CTDM
1610 CLS
1620 LOCATE 12,15
1630 INPUT " INPUT NAME OF RECEPTOR OUTPUT FILE~>"?ROUT$
1640 CLS
1650 'Open the receptor output file.
1660 OPEN ROUTS FOR OUTPUT AS #3
1710 'Begin loop over contours.
1720 FOR J-l TO NCI
1730 'Zero out the total distance traveled along the contour.
1740 TPDIS-0!
1750 'Input the number of points on the contour and the contour elevation.
1760 INPUT!1, NPC.HCOH
1770 'Write the number of contour points and the contour elevation to the
1780 'contour perimeter distance file.
1790 IF PERFLG%-0 THEN PRINT#2, NPC,HCON
1800 'Input the coordinates of the first contour point.
1810 INPUT!1, XI, Yl
1820 IF PERFLG%-0 THEN PRINT#2, XI,Yl,TPDIS:XB-X1:YB-Y1
1830 XOLD-X1
1840 YOLD-Y1
1850 'Set contour closure indicator to zero. The parameters DUPFLG% and IFR
1860 'are used to allow the plotting of multiple contours at the same
1870 'elevation.
1880 DUPFLG%-0
163
-------
1890 'Scale first contour point for plotting.
1900 XS1=SCRCX+(X1-XC)*DSCRXDDD
1910 YS1-SCRCY-(Y1-YC)*DSCRYDDD
1920 'Plot the first contour point.
1930 PSET(XS1,YS1)
1940 'Set contour closure counter to zero.
1950 IFR-O
1960 'Begin loop over the remainder of the contour points.
1970 FOR K-2 TO NPC
1980 INPUTll, X,Y
1990 'If 2 or more contour closures have been reached and the point has the
2000 'coordinates as the initial point, then skip over the point for plotting.
2010 IF IFR<2 THEN GOTO 2060
2020 IF ABS(X-X1)>1E-15 OR ABS(Y-Y1)>1E-15 THEN GOTO 2060
2030 IF PERFLG%»0 THEN PRINT#2, X,Y,TPDIS:XB-X:YB-Y
2040 GOTO 2310
2050 'Scale the point X,Y for plotting.
2060 XS-SCRCX+(X-XC)*DSCRXDDD
2070 YS-SCRCY-(Y-YC)*DSCRYDDD
2080 IF DUPFLG*-0 THEN GOTO 2210
2090 'One of the multiple contours has been closed. Move to the new point
2100 'without drawing a line. Substitute the current point for the previous
2110 'individual contour beginning point.
2120 XOLD-X
2130 YOLD-Y
2140 DUPFLG*-0
2150 PSET(XS,YS)
2160 IF PERFLG*-0 THEN PRINT#2, X,Y,TPDIS:XB-X:YB-Y
2170 GOTO 2310
2180 'Determine whether one of the individual multiple contours has been
2190 'closed. If so, set the closure indicator DUPFLG* to 1 and increment
2200 'the contour closure counter IFR by 1.
2210 IF ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG%-1:IFR-IFR+1
2220 'Draw a line from the previous point to the current point.
2230 LINE -(XS,YS)
2240 IF PERFLG%<>0 THEN GOTO 2310
2250 DL-SQR((X-XB)A2+(Y-YB)*2+1E-15)
2260 XB-X
2270 YB-Y
2280 TPDIS-TPDIS+DL
2290 PRINTI2, X,Y,TPDIS
2300 'End loop over contour points.
2310 NEXT K
2320 'If the contour perimeter distance file already exists, then read
2330 'through the file to find to find the total perimenter distance.
2340 IF PERFLG*-0 THEN GOTO 2410
2350 INPUTI2, IDUM.DUM
2360 FOR K-l TO NPC-1
2370 INPUTI2, XDUM,YDUM,TPDIS
2380 NEXT K
2390 INPOTI2, XDUM,YDUM,TPDIS
2400 'Skip over edited contour points.
2410 INPUTll, NPC,HDOM
2420 FOR K-l TO NPC
2430 INPUT*1, DUMX,DUMY
2440 NEXT K
2450 'Determine whether the user wishes to specify receptor spacing for
2460 'contour J directly or wants to have the spacing calculated based upon
2470 'a user specified number of evenly spaced points along the contour.
2480 LOCATE 1,1
164
-------
2490 INPUT "METHOD: 1)DL OR 2)N? (1 or 2)->";RMETH%
2500 LOCATE 1,1:PRINT " "
2510 IF RMETH%<1 OR RMETH%>2 THEN GOTO 2480
2520 IF RMETH%=-2 THEN GOTO 2590
2530 LOCATE 1,1
2540 INPUT "DISTANCE INCREMENT->";DL(J)
2550 IF DL(J)<1E-15 THEN GOTO 2530
2560 NREC(J)=INT(TPDIS/DL(J))
2570 IF NREC(J)->NRMAX THEN NREC(J) =NRMAX
2580 GOTO 2670
2590 LOCATE 1,1
2600 INPUT "NUMBER OF RECEPTORS->";NREC(J)
2610 IF NREC(J)>NRMAX THEN NREC(J)-NRMAX
2620 IF NREC(J)-0 THEN GOTO 2650
2630 DL(J)-TPDIS/NREC(J)
2640 GOTO 2670
2650 DL(J)-0!
2660 'End loop over contours
2670 LOCATE 1,1:PRINT " "
2680 NEXT J
2690 'Scale hill center coordinates.
2700 XSHC-SCRCX+(XHTOP-XC)*DSCRXDDD
2710 YSHOSCRCY-(YHTOP-YC)*DSCRYDDD
2720 XUL-XSHC-1
2730 XLR-XSHC+1
2740 YUL-YSHC-1
2750 YLR-YSHC+1
2760 'Plot a 3X3 box of points centered at the hill center.
2770 LINE(XUL,YUL)-(XLR,YLR),,BF
2780 'Close Filell
2790 CLOSE #1
2800 'Rewind FilefZ by a closing and opening operation.
2810 CLOSE 12
2820 OPEN PLOT2$ FOR INPUT AS 12
2850 'SJcip over File#2 identification information.
2860 INPUT#2, DUM$
2870 INPUTI2, 1DUM,HDUM$
2880 INPUT*2, NCI
2890 FOR J-l TO NCI
2900 INPUT#2, IDC1(J)
2910 NEXT J
2920 'Set total receptor number to zero.
2930 NUMRT-0
2940 'Begin loop over contours to generate receptor points.
2950 FOR J-l TO NCI
2960 'Set the number of digitized contour points read to zero.
2970 NPTS-0
2980 'Set the receptor for the individual contour to 1.
2990 NUMR-1
3000 'Read the number of points on the contour and the contour elevation.
3010 INPOTI2, NPC,HCON
3020 'If the number of receptor points is zero, then skip to the next contour.
3030 IF NREC(J)-0 THEN GOTO 3560
3040 'Place a receptor at the first contour point.
3050 INPUT#2, X,Y,PD
3060 'Increment the number of digitized contour points read by 1.
3070 NPTS-NPTS+1
3080 'Save the coordinates of the first point.
3090 XLAST-X:YLAST-Y:PDLAST-PD
3100 'Scale the first receptor point for plotting.
165
-------
3110 XP»SCRCX+(X-XC)*DSCRXDDD
3120 YP-SCRCY-(Y-YC)*DSCRYDDD
3130 'Plot a circle of radius IRAD with its center at this first receptor point.
3135 'If the center of the circle falls within a previously plotted receptor
3136 'circle, then paint out that portion of the previous circle which falls
3137 'within the new circle.
3138 CIRCLE(XP,YP),IRAD,0
3139 PAINT(XP,YP),0,0
3140 CIRCLE (XP,-YP) , IRAD, 1
3150 PAINT(XP,YP),1,1
3160 'Increment the total receptor number by 1.
3170 NUMRT-NUMRT+l
3180 'Write the coordinates of this point to the CTDM receptor input file.
3190 PRINT#3, USING IFMT$;HNAME1$,NUMRT,X,Y,ZERO,HCON,IDH1
3200 'Increment the contour receptor number by 1.
3210 NUMR-NUMR+1
3220 'Determine whether all receptors have been allocated for this contour.
3230 IP NUMR>NREC(J) THEN GOTO 3560
3240 'Find the distance(from the first contour point) to the next receptor
3250 'point.
3260 DISTR-(NUMR-1)*DL(J)
3270 'Read the coordinates and running perimeter distance for the next
3280 'digitized contour point unless the receptor perimeter distance is
3290 'less than the current running distance for the current contour point.
3300 IF DISTR<-PD THEN GOTO 3380
3310 XLAST-X:YLAST-Y:PDLAST-PD
3320 INPUTI2, X,Y,PD
3330 NPTS-NPTS+1
3340 'Determine whether this running distance is less than the distance to the
3350 'next receptor point.
3360 IF PDNREC(J) GOTO 3560
3550 GOTO 3260
3560 'Read through the remaining digitized contour points.
3570 FOR K-NPTS+1 TO NPC
3580 INPUT!2, DUM1,DUM2,DUM3
3590 NEXT K
3600 NEXT J
3610 LOCATE 1,1
3620 PRINT HNAME1$ " RECEPTORS "
3630 'Program execution will cease if the user presses any key
166
-------
3640 A$-INKEY$:IF A$-"" THEN GOTO 3640 ELSE SYSTEM
3650 IF ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUND-Press any key"
3660 A$~INKEY$:IF A?-1"1 THEN GOTO 3660
3670 SYSTEM
167
-------
.APPENDIX E
SETUP PROGRAM CODE LISTINGS
168
-------
APPENDIX E
SETUP PROGRAM CODE LISTINGS
Code listings for INTERACT, the set-up program for CTDM input
files, are included in this appendix. The routines are listed in
alphabetical order following the main program:
INTERACT
ATOF
ATOI
CROPT
CRPRO
CRSF1
CRSFC
DELAY
EXIST
FILES
JULIAN
MODINP
MODOPT
MODPRO
MODSF1
MODSFC
MODTER
MORE
NEWFLE
OLDFLE
PUTDOTS
RECS
SETPRE
STACK
SWNAHE
ZAPCHR
These code listings are followed by INCLUDE files containing
PARAMETER assignments (in "PARAMS.INC") and COMMON blocks:
HILL
PROFIL
RECEPT
STACKS
169
-------
INTERACT FORTRAN Code Listings
170
-------
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
o
c
c
c
c
c
c
c
c
e
c
c
c
c
program interact
Program: INTERACT
Purpose: This program allows the user to interactively set up
input files to CTDM and METPRO. This is accomplished by
writing to a "batch" file the DOS operating system commands
necessary to run the programs.
The user is guized for all necessary information including
existing? input file names. The user can change most of the
data inputs in any of the input files.
Assumptions/Limitations :
- CTDM. EXE and METPRO.EXE can be found (PATH is set correctly)
- all data files are in the current directory
- The file nameing convention used by METPRO and CTDM must
be followed
- you need to know file names before starting INTERACT
- the user can only modify an existing TERRAIN file
- the program does not check all input data for validity
- when you modify an existing file your new data is actually
written to the new file which is then renamed by
the batch file
General Comments:
Some FORTRAN compilers allow the execution of DOS system
from a program. The LAHEY F77L compiler allows this with the
SYSTEM subroutine. If the compiler you are using has this
feature then interact can be enhanced by uncommenting the
lines marked by 'c— «•»'. These statements allow the user to
list files in a directory and clear the screen. These lines
occur in:
interact
files
setpre
zapchr
Calls:
setpre - main subroutine for METPRO
zapchr - clears screen
delay - waits for user to continue program
exist - checks if file name exists in current directory
oldfle - opens an existing file
newfle - opens a new file
crinp - allows user to create a CTDM. IN file
aodinp - allows user to modify a CTDM. IN file
crpro - allows user to create a PROFILE file
modpro - allows user to modify a PROFILE file
crsfc - allows user to create a SURFACE file
modsfc - allows user to modify a SURFACE file
modter - allows user to modify a TERRAIN file
swname - writes commands to batch file which will switch two
file names
Version: 1.0 Level: 871109
integer no, yes
integer exist
character*! c
character*! 6 oname, nname, blank
data no/0/, yes/1/
data blank/1 '/
open batch command file
INT00010
• TMT^OHAOA
IN 1 U U02 0
INT00030
INT00040
INT00050
INT00060
INT00070
INT00080
INT00090
INT00100
INT00110
INT00120
INT00130
INT00140
INT00150
INT00160
INT00170
INT00180
INT00190
INT00200
INT00210
INT00220
INT00230
INT00240
INT00250
INT00260
INT00270
INT00280
INT00290
INT00300
INT00310
INT00320
INT00330
INT00340
INT00350
INT00360
INT00370
INT0038O-
INT00390
INT00400
INT00410
INT00420
INT00430
INT00440
INT00450
INT00460
INT00470
INT00480
INT00490
INT00500
INT00510
INT00520
INT00530
INT00540
INT00550
INT00570
INT00580
INT00590
INT00600
INT00610
INT00620
INT00630
INT00640
INT00650
INT00660
171
-------
open( 3, file='ctdm_cmd.bat', status='new')
100
&
&
&
&
&
&
call zapchr()
write(6,6000)
INTO0670
INT00680
INT00690
INTO 0700
INT00710
write(*,*)' Execute the CTDM meteorological1, INT00720
& ' preprocessor program, METPRO ? (Y/N):'INT00730
read(*,'(al)') c INT00740
if( c .eq. 'Y' .or. c .eq. 'y1 ) then INT00750
else
endif
call setpre
ipre = YES
ipre
NO
call zapchr()
write(*,6100)
iexl - exist (' CTDM. IN1)
if(iexl .eq. YES) then
write (*,*)
else
endif
write (*,*)
i
write ( * , * )
iexS - exist('RECEPTOR')
if(iex5 .eq. YES) then
write(*,*)
else
endif
write(*,*)
write(*,*)
iex2 - exist('PROFILE')
if(ipre .eq. YES) then
write(*,*)
else
if(iex2 .eq. YES) then
write(*,*)
else
write(*,*)
endif
endif
iex3 - exist('SURFACE')
if(ipre .eg. YES) then
rrt
else
write(*,*)
if(iex3 .eq. YES) then
write(*,*)
else
i
write(*,*)
INT00760
INTO0770
INT00780
INT00790
INT00800
INT00810
INT00320
INT00830
INT00840
INT00850
INT00860
INT00870
CTDM.IN file currently exists.'INT00880
INT00890
INT00900
CTDM.IN file does not exist.1 INT00910
INT00920
NOTE: This program cannot create', INT00930
' one from scratch.' INT00940
INT00950
INT00960
INT00970
INT00980
INT00990
RECEPTOR file currently exists.1 INTO LOGO
INT01010
INTO 1020
INT01030
INT01040-
INTO1050
INTO1060
INTO1070
INTO1080
INT01090
INT01100
INTO1110
PROFILE file setup by METPRO1 INT01120
INT01130
INT01140
INT01150
PROFILE file currently exists1 INT01160
INTO1170
INT01180
PROFILE file does not exist' INT01190
INTO1200
INTO 1,210
INTO1220
INTO 1.2 30
INT01240
SURFACE file created by METPRO'INTO1250
INT01260
INT01270
INTO1280
SURFACE file currently exists1 INT01290
INT01300
INT01310
SURFACE file does not exist1 INT01320
RECEPTOR file does not exist.1
NOTE: This program cannot create',
1 one from scratch.'
172
-------
endif
endif
iex4 = exist('TERRAIN')
if(iex4 . eq. YES) then
write(*,*)
else
write(*,*)
write(*,*)
endif
call delay
call zapchr()
write(3,*) ' •
if(iexl .eg. YES) then
wr£te(*,6666)
write(*,*)'
TERRAIN file currently exists'
TERRAIN file does not exist1
NOTE: This program cannot create',
' one from scratch1
c .eq. 'm') then
Modify existing CTDM.IN file (M),',
' or Continue (RETURN): '
read(*,'(al)') c
if(c .eq. 'M1 .or.
write(*,*)' '
write(*,*)' Rename existing CTDM.IN file1
open(1,f ile='CTDM.IN',status-'OLD')
call newfle(2,nname)
call delay
call modinp
call swname('CTDM.IN',nname)
200
c-*-*-*
£.*-*_*
endif
else
write(* 6666)
write(*
writs(*
write(*
write(*
6661)
*)
- Create a new CTDM.IN file (N)'
*)' Enter M, N, or R:
*) '
c_*_*-*.
c-*-*-*-
read(*,•(al)') c
if(c .eq. 'M' .or. c .eq. 'm') then
call oldfle(l,oname)
if( oname .eq. blank) go to 200
open(2,file-'CTDM.IN',status-'NEW')
call modinp
else if(c .eq. 'R' .or. c .eq. 'r') then
call oldfle(l,oname)
if( oname .eq. blank) go to 200
write(3,3100) oname
else if(c .eq. 'N1 .or. c .eq. 'n') then
open(1,file-'CTDM.IN',status-'NEW')
call crinp
else if(c .eq. 'Q' .or. c .eq. 'q') then
go to 9999
else if(c .eq. 'D' .or. c .eq. 'd') then
call files
call delay
call zapchr()
go to 200
else
?o to 200
f
endif
call zapchr()
if(iex5 .eq. YES) then
write(*,6666)
Enter M, R, D, or Q:
INT01330
INT01340
INT01350
INT01360
INT01370
INT01380
INT01390
INT01400
INT01410
INT01420
INTO 1430
INT01440
INT01450
INT01460
INT01470
INT01480
INT01490
INT01500
INT01510
INT01520
INT01530
INT01540
INT01550
INT01560
INT01570
INT01580
INT01590
INT01600
INT01610
INT01620
INTO1630
INT01640
INT01650
INT01660
INT01670
INT01680
INT01690
INT01709-
INT01710
INT01720
INT01730
INT01740
INT01750
INT01760
INT01770
INTO1780
INT01790
INT01800
INT01810
INTO1820
INT01830
INT01840
INT01850
INT01860
INT01870
INT01880
INT01890
INT01900
INTO1910
INT01920
INT01930
INTO1940
INT01950
INTO1960
INT01970
INTO1980
173
-------
c .eq. 'm') then
write(*,*)' Modify existing RECEPTOR file (M),
& ' or Continue (RETURN): '
read(*,'(al)') c
if(c .eq. 'M1 .or.
write(*,*)' '
write(*,*)' Rename existing RECEPTOR file
open(1,file='RECEPTOR',status='OLD')
call newfle(2,nname)
call delay
call recs
call swname('RECEPTOR',nname)
end if
else
250 write(*,6666)
write(*,6665)
c=======—=»write (*,*)' Enter M, R, D, or Q:
writef*,*)1 Enter M, R, or Q: '
read(*,'(al)') c
if(c .eq. 'M' .or. c .eq. 'm') then
call oldfle(l,oname)
if( oname .eq. blank) go to 250
open(2,rile-'RECEPTOR',status-'NEW•)
call recs
else if(c .eq. 'R1 .or. c .eq. 'r') then
call oldfle(1,oname)
if( oname .eq. blank) go to 250
write(3,3150) oname
else if(c .eq. 'Q' .or. c .eq. 'q') then
go to 9999
else if(c .eq. 'D1 .or. c eq. 'd') then
call delay
c=
c-=
c—»
c—«
•——ca 11 zapchr()
•-— go to 250
else
go to 250
endif
endif
call zapchr()
if(ipre .eq. YES) go to
if(iex2 .eq. YES) then
write(*,6666)
write(*,*)'
read(*,'(al)') c
440
Modify existing PROFILE file (M)
or Continue (RETURN): '
if(c .eq.
'M1
300
c=
.or. c .eq. 'm') then
~write(*,*)' '
write(*,*)' Rename existing PROFILE file
open(1,file-'PROFILE',status-'OLD')
call newfle(2,nname)
call delay
call modpro
call swname('PROFILE',nname)
endif
else
write(*,6666)
write(*,6662)
.—write(*,*)' Enter M, N, R,
write(*,*)' Enter M, N, R,
read(*,'(al)') c
if(c .eq. 'M' .or. c .eq. 'm') then
call oldfle(l,oname)
if( oname .eq. blank) go to 300
open(2,file-'PROFILE',status-'NEW')
call modpro
D, or Q:'
or, Q:'
,INT01990
INT02000
INT02010
INT02020
INT02030
'INT02040
INT02050
INT02060
INTO2070
INTO2080
INTO2090
INT02100
INTO2110
INT02120
INT02130
'INTO2140
INT02150
INT02160
INT02170
INT02180
INT02190
INT02200
INT02210
INT02220
INT02230
INT02240
INT02250
INT02260
INT02270
INT02280
INT02290
INT02300
INT02310
INT02320
INT02330
INT02340
INT02350
INTO23&6-
INT02370
INT02380
INT02390
INT02400
INT02410
,INT02420
INT02430
INT02440
INT02450
INT02460
'INT02470
INT02480
INT02490
INT02500
INT02510
INT02520
INT02530
INT02540
INT02550
INT02560
INT02570
INT02580
INT02590
INT02600
INT02610
INT02620
INTO2630
INT02640
174
-------
c«
c=
c»
c=
c=
else if(c .eg. 'R1 .or. c .eq. 'r') then
call oldfle(l,oname)
if( oname .eq. blanJc) go to 300
write(3,3200) oname
else if(c .eq. 'N1 .or. c .eq. 'n') then
open(1,file-'PROFILE',status='NEW')
call crpro
==else if(c .eq. 'D
=call files
•call delay
•call zapchr()
=go to 300
else if(c .eq. 'Q
go to 9999
else
go to 300
.or. c .eq. 'd') then
.or. c .eq. 'q') then
endif
400
O»
endif
call zapchr()
if(ipre .eq. YES) go to 440
if(iex3 .eq. YES) then
write(*,6666)
write(*,*)' Modify existing SURFACE file
1 or Continue (RETURN): '
read(*,'(al)') c
if(c .eq. 'M1 .or. c .eq. 'm') then
write(*,*)' '
write(*,*)' Rename existing SURFACE
open(1,file-'SURFACE',status-'OLD')
call newfle(2,nname)
call delay
call modsfc
call swname('SURFACE',nname)
endif
else
write(*,6666)
write(*,6663)
write(*,*) '
read(*.•(al)')
if(c .eq. 'M
Enter M, N, R, D, or
Enter M, N, R, or Q:
c
.or. c .eq. 'm') then
call oldfle(l,oname)
if( oname .eq. blank) go to 400
open(2,file-'SURFACE',status-•NEW')
call modsfc
else if(c .eq. 'R' .or. c .eq. 'r') then
call oldfle(l,oname)
iff oname .eq. blank) go to 400
write(3,3300) oname
else if(c .eq. 'N1 .or. c .eq. 'n') then
open(1,file-'SURFACE',status-'NEW')
call crsfc
•else if(c .eq. 'D' .or. c .eq. 'd') then
call files
c==
endif
•—call delay
•—-call zapchr()
•—go to 400
else if(c .eq. '
go to 9999
else
go to 400
endif
.or. c .eq. 'q') then
INT02650
INT02660
INT02670
INT02680
INT02690
INT02700
INT02710
INT02720
INT02730
INT02740
INT02750
INT02760
INT02770
INT02780
INT02790
INT02800
INT02810
INT02820
INT02830
INT02840
INT02850
INT02860
INT02870
INT02880
(M),',INT02890
INT02900
INT02910
INT02920
INT02930
file'INT02940
INT02950
INT02960
INT02970
INT02980
INT02990
INT03000
INT03010
INTO302«-
INT03030
Q: ' INT03040
' INT03050
INT03060
INT03070
INT03080
INT03090
INT03100
INT03110
INT03120
INT03130
INTO3140
INT03150
INT03160
INT03170
INT03180
INT03190
INT03200
INT03210
INT03220
INT03230
INT03240
INT03250
INT03260
INT03270
INT03280
INT03290
INT03300
175
-------
c .eq. 'm') then
440 call zapchr()
if(iex4 .eg. YES) then
write(*,6666)
write(*,*)' Modify existing TERRAIN file (M) ,
& ' or Continue (RETURN): '
read(*,'(al)') c
if(c .eq. 'M' .or.
write(*,*)' '
write(*,*)' Rename existing TERRAIN file
open(1,file='TERRAIN',status='OLD')
call newfle(2,nname)
call delay
call modter
ca11 swname('TERRAIN',nname)
endif
else
460 write(*,6666)
write(*,6664)
rite(*,*)'
write(*,*)•
read(*,'(al)') c
if(c .eq. 'M' .or. c .eq. 'm') then
call oldfle(l,oname)
if( oname .eq. blank) go to 460
open(2,file-'TERRAIN',status-'NEW')
call modter
else if(c .eq. 'R1 .or. c .eq. 'r')
call oldfle(l,oname)
if( oname .eq. blank) go to 460
write(3,3400) oname
Enter M,
Enter M,
R,
R,
D, or Q:
or Q: '
then
•else if(c .eq. '!
.—call files
•—call delay
•—call zapchr()
•—go to 460
else if(c .eq. '<
go to 9999
else
go to 460
endif
.or. c .eq. 'd') then
.or. c .eq. 'q') then
500
endif
check CTDM output files here
iexS - exist('CTDM.OUT1)
iex9 - exist('CONC')
call zapchr()
call zapchrQ
if(iex8 .eg. YES) then
write(*,6666)
writa(*,*)'
write(*,*)'
read(*,'(al)') c
if(c .eq. 'D1 .or.
write(3,*)' DEL CTDM.OUT1
CTDM output file CTDM.OUT exists1
Delete (D), or Rename (R):
c . eq. 'd') then
510
else if(c .eq. 'R'
write(*,*)'
else
endif
.or. c .eq. 'r') then
Rename CTDM.OUT, ',
Enter new file name: '
read(*,'(a!6)') nname
iexx - exist(nname)
if( iexx .eq. YES ) go to' 510
write(3,*)' Rename CTDM.OUT ',nname
go to 500
INT03310
INT03320
INT03330
INTO 3340
,INT03350
INT03360
INT03370
INT03380
INT03390
'INT03400
INT03410
INT03420
INT03430
INT03440
INT03450
INT03460
INT03470
INT03480
INT03490
INT03500
INT03510
INT03520
INT03530
INT03540
INT03550
INT03560
INT03570
INT03580
INT03590
INT03600
INT03610
INT03620
INT03630
INT03640
INT03650
INT03660
INT03670
INT036S4-
INT03690
INT03700
INT03710
INT03720
INT03730
INT03740
INT03750
INT03760
INTO3770
INT03780
INT03790
INTO3800
INT03810
INT03820
'INT03830
INTO3840
INT03850
INT03860
INT03870
INT03880
INT03890
INT03900
INTO3910
INT03920
INT03930
INT03940
INT03950
INTO3960
176
-------
520
CTDM output file CONC exists,
Delete (D), or Rename (R):
530
end if
call zapchr()
if(iex9 .eq. YES) then
write<*,6666)
write(*,*)'
write(*,*)'
read(*,'(al)') c
if(c .eq. 'D1 .or.
write(3,*)'
else if(c .eq. 'R'
write(*,*)'
1 Enter new
read(*,'(a!6)') nname
iexx - exist(nname)
if( iexx .eq. YES ) go to 530
write(3,*)' Rename CONC ',nname
c .eq. 'd')
DEL CONC '
.or. c .eq.
then
) then
Rename CONC,
filename:'
endif
else
end if
9999
write(3,*)'
stop
write(*,6666)
go to 520
CTDM'
3100
3150
3200
3300
3400
write(*,*) •-+-*- INTERACT Program Terminating -*-+-'
write (*,*)
write(*,*)' CAUTION: Program terminated before completion.1
write (*,*)' Check all modified files to ensure '
write(*,*)' all modifications have been incorporated
stop
format ( ' Rename
format ( ' Rename
format ( ' Rename
format ( ' Rename
/ a,
, a,
/ a,
, a,
CTDM. IN')
RECEPTOR ' )
PROFILE ' )
SURFACE ' )
format ( ' Rename , a , TERRAIN ' )
6000
6100
6661
6662
&
&
&
&
&
&
&
&
&
&
&
•&
&
&
&
&
&
&
INT03970
INT03980
INT03990
INT04000
INT04010
INT04020
'INT04030
INT04040
INT04050
INT04060
INT04070
INT04080
INT04090
INT04100
INT04110
INT04120
INT04130
INT04140
INT04150
INT04160
INT04170
INT04180
INT04190
INT04200
INT04210
INT04220
INT04230
INT04240
INT04250
INT04260
INT04270
INT04280
INT04290
INT04300
INT04310
INT04320
INT04330
format('
is:'/' ')
6663
CTDM Interactive Program Setup'//
Version 1.0 Level 871028'////)
format(
' CTDM requires the following input files1//,
- CTDM.IN'/,
- RECEPTOR'/,
- PROFILE'/,
- SURFACE'/,
- TERRAIN1//,
The status of these files
format(
CTDM.IN file does not exist
- Use an existing file (M)
The existing file
- Rename an existing file to CTDM.IN (R)'/
- Execute DOS Directory command (D)'/
- Quit (Q)'//)
format(
PROFILE file does not exist. Do you want to
- Use an existing file (M) to create PROFILE'/INT04550
The existing file is left unchanged'/INT04560
- Rename an existing file to PROFILE (R)'/ INT04570
- Create a new PROFILE file (N)'/ INT04580
- Execute DOS Directory command (D)'/ INT04590
- Quit (Q)'//) INT04600
format( INT04610
1 SURFACE file does not exist. Do you want to:'//INT04620
INT04350
INT04360
INT04370
INT04380
INT04390
INT04400
INT04410
INT04420
INT04430
INT04440
INT04450
INT04460
Do you want to:'//INT04470
to create CTDM.IN'/INT04480
is left unchanged'/INT04490
._.. INT04500
INT04510
INT04520
INT04530
'//INT04540
177
-------
&
&
&
&
c====&
SL
6664 1
&
&
&
&
C====&
&
6665 1
&
&
&
&
&
format (
format (
- Use an existing file (M) to create SURFACE'/INT04630
The existing file is left unchanged'/INT04640
- Rename an existing file to SURFACE (R)'/ INT04650
- Create a new SURFACE file (N)'/ INTC4660
- Execute DOS Directory command (D)'/ INT04670
- Quit (Q)'//) INT04630
INT04690
TERRAIN file does not exist. Do you want to:'//INT04700
- Use an existing file (M) to create TERRAIN'/INT04710
The existing file is left unchanged'/INT04720
- Rename an existing file to TERRAIN (R)'/
- Execute DOS Directory command (D)'/
- Quit (Q)'//)
INT04730
INT04740
INT04750
INT04760
'//INT04770
6666
format(////////)
end
RECEPTOR file does not exist. Do you want to
- Use an existing file (M) to create RECEPTOR'/INT04780
The existing file is left unchanged'/INT04790
- Rename an existing file to RECEPTOR (R)'/ INT04800
- Execute DOS Directory command (D)'/ INT04810
- Quit (Q)'//) INT04820
INT04830
INT04840
178
-------
integer function atof( s, r )
c Function: atof
c
c Purpose: Convert a character string of integers to the floating
c point number represent
c
c Limitations:
c - character string is a most 10 characters
c - any noh-integer can be used as the delimiter
c
c Arguments:
c Passed
c s chr character string length MEXLEN
c Returned
c r int integer
c
c Function Value:
c atof int error flag (0=OK, -1=ERROR)
c
c Called By: Many routines
c
c Calls: None
c
c Version 1.0 Level 871109
c
parameter ( MAXLEN - 10)
character*10 s
integer ERROR, OK
data ERROR/-1/, OK/0/
atof - ERROR
r - 0.0
ip - 0
c delete leading blanks
k»0
10 k-k+1
if( k .gt. MAXLEN ) go to 40
if( s(k:k) .eg. ' ') go to 10
c check for leading + or - sign
if( s(k:k) .eq. ' + ' ) then
k-k+1
is - 1
else iff s(k:k) .eq. '-' ) then
k-k+1
is - -l
else
is - l
endif
c start looping on chars to the left of decimal point
20 r - 0.0
30 if( k .gt. MAXLEN ) go to 50
if( s(k:k) .ge. '0' .and. s(k:k) .le. '91 ) then
r - 10. * r + float (ichar(s(k:k) ) ) - float(ichar( '0') }
k-k + 1
atof - OK
go to 30
endif
c check for decimal point
if ( s(k:k) .eq. '. ' ) then
atof - OK
k-k+1
ATF00010
ATF00030
ATF00040
ATF00050
ATF00060
ATF00070
ATF00080
ATF00090
ATF00100
ATF00110
ATF00120
ATF00130
ATF00140
ATF00150
ATF00160
ATF00170
ATF00130
ATF00190
ATF00200
ATF00210
ATF00220
ATF00230
ATF00240
ATF00250
ATF00270
ATF00280
ATF00290
ATF00300
ATF00310
ATF00320
ATF00330
ATF00340
ATF00350
ATF00360
ATF00370
ATF00386-
ATF00390
ATF00400
ATF00410
ATF00420
ATF00430
ATF00440
ATF00450
ATF00460
ATF00470
ATF00480
ATF00490
ATF00500
ATF00510
ATF00520
ATF00530
ATF00540
ATF00550
ATF00560
ATF00570
ATF00580
ATF00590
ATF00600
ATF00610
ATF00620
ATF00630
ATF00640
ATF00650
ATF00660
179
-------
c decimal portion of real number ATF00670
35 if( k .gt. MAXLEN ) go to 40 ATF00680
if( s(k:k) .ge. '0' .and. s(k:k) .le. '9' ) then ATF00690
r = 10. * r -t- float(ichar(s(k:k))) - ATF00700
& float(ichar('0')) ATF00710
k = k + 1 ATF00720
ip = ip + 1 ATF00730
go to 35 ATF00740
endif ATF00750
go to 40 ATF00760
endif ATF00770
40 if( ip .gt. 0 ) then ATF00780
r = float(is) * r / float(10**ip) ATF00790
else ATF00800
r =» float(is) * r ATF00810
endif ATF00820
return ATF00830
ATF00840
50 atoi - ERROR ATF00850
return ATF00860
end ATF00870
180
-------
integer function atoi( s, i )
c Function: atoi
c
c Purpose: Convert a character string of integers to the integer they
c represent
c
c Limitations:
c - character string is a most 10 characters
c - any non-integer can be used as the delimiter
c
c Arguments:
c Passed
c s chr character string length MEXLEN
c Returned
c i int integer
c
c Function Value:
c atoi int error flag (0=OK, -1=ERROR)
c
c Called By: Many routines
c
c Calls: None
c
c Version 1.0 Level 871109
c
parameter ( MAXLEN = 10)
character* 10 s
integer ERROR, OK
data ERROR/-1/, OK/0/
atoi » ERROR
i - 0
c delete leading blanks
k-0
10 k-k+l
iff Jc .gt. MAXLEN ) go to 50
if( s(k:k) .eq. ' ') go to 10
c check for leading + or - sign
if( s(k:k) .eq. '+' ) then
k-k+l
is - 1
else if( s(k:k) .eq. '-' ) then
k-k+l
is » -1
else
is - 1
endif
c start looping on integers
20 i - 0
30 if( k .gt. MAXLEN ) go to 40
c only look at integers
iff s(k:k) .ge. '0' .and. s(k:k) .le. '9' ) then
i - 10 * i + ichar(s(k:k)) - ichar('O')
k - k + 1
atoi - OK
go to 30
endif
40 i - is * i
return
50 atoi - ERROR
return
end
ATI00010
ATI00030
ATI00040
ATI00050
ATI00060
ATI00070
ATI00080
ATI00090
ATI00100
ATI00110
ATI00120
ATI00130
ATI00140
ATI00150
ATI00160
ATI00170
ATI00180
ATI00190
ATI00200
ATI00210
ATI00220
ATI00230
ATI00240
ATI00250
ATI00270
ATI00280
ATI00290
ATI00300
ATI00310
ATI00320
ATI00330
ATI00340
ATI00350
ATI00360
ATI00370
ATI00380-
ATI00390
ATI00400
ATI00410
ATI00420
ATI00430
ATI00440
ATI00450
ATI00460
ATI00470
ATI00480
ATI00490
ATI00500
ATI00510
ATI00520
ATI00530
ATI00540
ATI00550
ATI00560
ATI00570
ATI00580
ATI00590
ATI00600
ATI00610
ATI00620
ATI00630
ATI00640
ATI00650
181
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
105
200
210
220
subroutine cropt
Subroutine: CROPT
Purpose: Create OPTIONS input file to METPRO.
Assumptions/Limitations :
I/O:
-
Called By:
Calls:
Version: 1.0 Level: 871109
real xlat, xlon, zO, al, br
integer atof, atoi, itz, ientry
integer YES
character c
character*10 clO
data YES/ I/
call zapchr()
write(*,*) ' Create OPTIONS file.1
write (*,*)
icase - 0
write (*,*)
write (*,*) ' Enter Latitude [deg]: '
read(*,5000) clO
ierr » atof(clO,x)
if( ierr .ne. -1 ) then
if(x .ge. -90. .and. x .le. 90.) then
xlat- x
else
go to 200
endif
else
go to 200
endif
write(*,*)' Enter Longitude [deg]: '
read (*, 5000) clO
ierr - atof(clO,x)
if( ierr .ne. -l ) then
if(x .ge. -180. .and. x .le. ISO.) then
xlon- x
else
go to 210
endif
else
go to 210
endif
write (*,*) ' Enter Time Zone: '
read (*, 5000) clO
ierr =• atoi(clO,ix)
if( ierr .ne. -1 ) then
if(ix .ge. -12 .and. ix .le. 12) then
itz - ix
else
go to 220
endif
else
go to 220
COP00010
COP00030
COP00040
COP00050
COP00060
COP00070
COP00080
COP00090
COP00100
COP00110
COP00120
COP00130
COP00140
COP00150
COP00170
COP00180
COP00190
COP00200
COP00210
COP00220
COP00230
COP00240
COP00250
COP00260
COP00270
COP00280
COP00290
COP00300
COP00310
COP00320
COP00330
COP00340
COP00350
COP00360
COP00370
COP0038fl_
COP00390
COP00400
COP00410
COP00420
COP00430
COP00440
COP00450
COP00460
COP00470
COP00480
COP00490
COP00500
COP00510
COP00520
COP00530
COP00540
COP00550
COP00560
COP00570
COP00580
COP00590
COP00600
COP00610
COP00620
COP00630
COP00640
COP00650
COP00660
ti
182
-------
230
240
250
300
310
320
400
999
5000
6000
endif
write(*,*) ' Enter Surface Roughness Length [m] :
read(*,5000) clO
ierr = atof(clO,x)
if( ierr .ne. -1 ) then
zO = x
else
go to 230
endif
write(*,*) ' Enter Albedo: '
read(*,5000) clO
ierr = atof(clO, x)
if( ierr .ne. -1 ) then
if(x .ge. 0.0 -and. x .le. 1.0) then
al - x
else
go to 240
endif
else
go to 240
endif
write(*,*) ' Enter Bowen Ratio: '
read(*,5000) clO
ierr » atof(clo, x)
if( ierr .ne. -1 ) then
if(x .ge. 0.0) then
br - x
else
go to 250
endif
else
go to 250
endif
call zapchr()
write(*,6000) xlat, xlon, itz, zO, al, br
write(*,*) • Inputs OK ? [Y/N] : '
read(*,'(al) ') c
.or. c .eq. 'y') go to 400
c .eg. 'n1) go to 320
if(c .eg, 'Y'
if(c .eg. 'N' .or.
go to 310
ientry - YES
call entopt(ientry, xlat, xlon, itz, zo, al, br)
go to 300
write(l,*) lease
write(l,*) xlat, xlon, itz, zO, al, br
call delay
return
format(alO)
format(' '/
OPTIONS FILE - CASE STUDY MODE1//
Latitude: ',f7.3,' (deg]'/
Longitude: ',f7.3,' [deg]•/
Time Zone: ',i2,/
Surface Roughness Length: ',f5.2,' [m]'/
Albedo: ',f5.2,/
Bowen Ratio: ',f5.2,/)
end
COP00670
COP00680
COP00690
COP00700
COP00710
COP00720
COP00730
COP00740
COP00750
COP00760
COP00770
COP00730
COP00790
COP00800
COP00810
COP00820
COP00830
COP00840
COP00850
COP00860
COP00870
COP00830
COP00890
COP00900
COP00910
COP00920
COP00930
COP00940
COP00950
COP00960
COP00970
COP00980
COP00990
COP01000
COP01010
COP01020
COP01030
COP0104Q_
COP01050
COP01060
COP01070
COP01080
COP01090
COP01100
COP01110
COP01120
COP01130
COP01140
COP01150
COP01160
COP01170
COP01180
COP01190
COP01200
COP01210
COP01220
COP01230
COP01240
COP01250
COP01260
183
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
100
110
240
subroutine crpro
Program: CRPRO
Purpose: Allows user to interactively modify a "PROFILE" input file.
Assumptions/Limitations :
- all files have already been opened
_
I/O:
- screen (console) quiz user
- unit 1 PROFILE file to be modified
- unit 2 new PROFILE file
Called By:
Calls:
Include Files:
Version: 1.0 Level: 871109
include ' params . inc '
include 'profil.cmn1
integer no, yes
integer atoi, atof
real sigth(MAXLEV)
character cl
character*10 clO
data no/0/, yes/ I/
call zapchr()
write (*,*)' create PROFILE data file.1
write(*,*)
nh - 0
write (*,*)' Enter date info.1
write(*,*)' Enter 2-digit year: '
read(*,*) iyr
write(*,*)' Enter month [1-12]: '
read ( * , * ) imo
write (*,*)' Enter day of month [1-31]: '
read(*,*) idy
write(*,*)' Enter hour [1-24]: '
read(*,*) ihr
nh - nh + 1
if(nh .eg. 1) then
write(*,*)' Enter height [m] : '
else
write(*,*)« Previous height was «,ht(nh-l),
& ' Next height [m] : '
endif
read(*,*) ht(nh)
if(nh .gt. 1) then
iffht(nh) .le. ht(nh-l)) then
write(*,*)' Height is less than previous level!
go to 240
endif
endif
write(*,*) ' Enter profile data (Hit RETURN for missing data) '
CPR00010
• CPR00020
CPR00030
CPR00040
CPR00050
CPR00060
CPR00070
CPR00080
CPR00090
CPR00100
CPR00110
CPR00120
CPR00130
CPR00140
CPR00150
CPR00160
CPR00170
CPR00180
CPR00190
CPR00200
CPR00210
CPR00230
CPR00240
CPR00250
CPR00260
CPR00270
CPR00280
CPR00290
CPR00300
CPR00310
CPR00320
CPR00330
CPR00340
CPR00350
CPR00360
CPR00370
CPR0038Q-
CPR00390
CPR00400
CPR00410
CPR00420
CPR00430
CPR00440
CPR00450
CPR00460
CPR00470
CPR00480
CPR00490
CPR00500
CPR00510
CPR00520
CPR00530
CPR00540
CPR00550
CPR00560
CPR00570
CPR00580
CPR00590
'CPR00600
CPR00610
CPR00620
CPR00630
CPR00640
CPR00650
184
-------
250
write(*,*)
write(*,*) ' Enter wind direction [deg]:
read(*,5000) clO
ierr * atof(clO,x)
if(ierr .eq. -1) then
wdhr(nh) = -999.0
else
end if
wdhr(nh) - x
if(wdhr(nh) .gt. 360.0) then
write(*,*)' Invalid wind direction! Try Again.'
go to 250
endif
260
write(*,*)' Enter scalar wind speed [m/s]:
read(*,5000) clO
ierr =• atof(clO,x)
if(ierr .eq. -1) then
wshr(nh) = -999.0
else
wshr(nh) =• x
endif
write(*,*)' Enter vector wind speed [m/s]:
read(*,5000) clO
ierr - atof(c!0,x)
if(ierr .eq. -1) then
uvhr-(nh) - -999.0
else
endif
uvhr(nh) - x
if(uvhrfnh) .gt. wshr(nh) .and. wshr(nh) .ge. 0.0) then
write(*,*)' Vector wind speed greater than1,
1 scalar wind speed!'
go to 260
endif
270
write(*,*)' Enter temperature [deg-K]:
read(*,5000) clO
ierr * atof(clO,x)
if(ierr .eq. -1) then
tahr(nh) - -999.0
else
tahr(nh) - x
endif
write(*,*)' Enter sigma-theta [deg]: '
read(*,5000) CIO
ierr » atof(clO,x)
if(ierr .eq. -1) then
sigth(nh) - -999.0
else
endif
sigth(nh) - x
if(sigth(nh) .gt. 103.9) then
write(*,*)' Sigma-Theta too large!
go to 270
endif
write(*,*)' Enter sigma-w [m/s]:
read(*,5000) clO
ierr - atof(clO,x)
if(ierr .eq. -1) then
swhr(nh) - -999.0
else
swhr(nh) - x
CPR00660
CPR00670
CPR00680
CPR00690
CPR00700
CPR00710
CPR00720
CPR00730
CPR00740
CPR00750
CPR00760
CPR00770
CPR00780
CPR00790
CPR00800
CPR00810
CPR00820
CPR00830
CPR00840
CPR00850
CPR00860
CPR00870
CPR00880
CPR00890
CPR00900
CPR00910
CPR00920
CPR00930
CPR00940
CPR00950
CPR00960
CPR00970
CPR00980
CPR00990
CPR01000
CPR01010
CPR01020
CPR0103&.
CPR01040
CPR01050
CPR01060
CPR01070
CPR01080
CPR01090
CPR01100
CPR01110
CPR01120
CPR01130
CPR01140
CPR01150
CPR01160
CPR01170
CPR01180
CPR01190
CPR01200
CPR01210
CPR01220
CPR01230
CPR01240
CPR01250
CPR01260
CPR01270
CPR01280
CPR01290
CPR01300
CPR01310
185
-------
400
11
410
420
430
999
5000
6000
6001
6010
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
enaii
write(*,*)' Is this the last level for this hour (Y/N)? '
read(*, ' (al) ') cl
if(cl .eg. 'Y1 .or. cl .eq. 'y') then
lend = NO
do 410 n=l,nh
if(n .eq. nh) iend = YES
if(wdhr(n) .It. 0.0) wdhr(n) = -999.0
if(wshr(n) .It. 0.0) wshr(n) = -999.0
if(tahr(n) .It. 0.0) tahr(n) = -999.0
if(sigth(n) .It. O.O)sigth(n) = -999.0
if(swhr(n) .It. 0.0) swhr(n) = -999.0
if(uvhr(n) .It. 0.0) uvhr(n) = -999.0
write(l,ll) iyr, imo, idy, ihr, ht(n), iend,
wdhr(n) , wshr(n) , tahr(n) ,
sigth(n), swhr(n) , uvhr(n)
format (4 ( 12 , Ix) , f 9 . 3 , Ix, il , Ix , 6 ( IpelO . 3 , Ix) )
continue
call zapchr()
write (6, 6000) imo, idy, iyr, ihr
do 430 n-l,nh
if (mod (n, 15) .eg. 1 .and. n .ne. l) then
call delay
call zapchrO
write(6,6001) imo, idy, iyr, ihr
endif
write(6,6010) n,ht(n) ,wdhr(n) ,wshr(n) ,uvhr(n) ,
tahr(n) , sigth(n) , swhr(n)
continue
write(*,*)' start new hour (Y/N) ? '
read(*, ' (al) ') cl
if(cl .eq. 'Y1 .or. cl .eq. 'y') go to 100
go to 999
else
go to 110
endif
return
format (alO)
formate Meteorological Profile Data ',
12, '/', 12, '/', 12,' Hour:',i3,/
1 Level Wind — Wind Speed — Ambient Sigma Sigma
/
' 1 Height Dir Scalar Vector Temp Theta w
/
[m] [deg] [m/s] [m/s] [deg-K] [deg] [m/s]
)
formate Meteorological Profile Data ',
12, '/',i2, '/'/i2, ' Hour: ',13,' cent.1/
1 Level Wind — Wind Speed — Ambient Sigma Sigma
/
1 f Height Dir Sealer Vector Temp Theta w
/
[m] [deg] [m/s] [m/s] [deg-K] [deg] [m/s]
)
format(i6,f9.1,3x,f5.1,2(3x,f5.2),3x,f6.2,2(2x,f5.2))
end
CPR01320
CPR01330
CPR01340
CPR01350
CPR01360
CPR01370
CPR01380
CPR01390
CPR01400
CPR01410
CPR01420
CPR01430
CPR01440
CPR01450
CPR01460
CPR01470
CPR01480
CPR01490
CPR01500
CPR01510
CPR01520
CPR01530
CPR01540
CPR01550
CPR01560
CPR01570
CPR01580
CPR01590
CPR01600
CPR01610
CPR01620
CPR01630
CPR01640
CPR01650
CPR01660
CPR01670
CPR01630
CPR01690
CPR0170CT
CPR01710
CPR01720
CPR01730
CPR01740
CPR01750
CPR01760
CPR01770
•CPR01780
CPR01790
'CPR01800
CPR01810
'CPR01820
CPR01830
CPR01840
CPR01850
'CPR01860
CPR01870
'CPR01880
CPR01890
'CPR01900
CPR01910
CPR01920
CPR01930
/I*
186
-------
subroutine crsfl
c Program: CRSF1
c
c Purpose: Create a SURFl input file to METPRO.
c
c Assumptions/Limitations:
c
c I/O:
c
c Called By:
c
c Calls
c
c Include Files:
c
c Version: 1.0 Level: 871109
integer atof, atoi
integer ch, cc
character c
character*10 clO
100 write (*,*)
105 call zapchr()
write(*,*) ' Create SURFl input file.1
write (*,*)
110 write(*,*)' Enter date info.'
write(*,*)' Enter 2-digit year: '
read(*,*) iyr
write(*,*)' Enter month [1-12]: '
read(*,*) imo
write(*,*)« Enter day of month [1-31]: '
read(*,*) idy
write(*,*)' Enter hour [1-24]: '
read(*,*) ihr
write(*,*) ' Hit RETURN to indicate missing data.1
write(*,*)
write(*,*) • Enter Total incoming solar radiation [w/m2]:'
read (*, 5000) clO
ierr - atof (clO,x)
if( ierr . ne. -1 ) then
qr • x
else
qr - -9999.
endif
write(*,*)' Enter Net Radiation [w/m2]:'
read(*,5000) clO
ierr * atof (clO,x)
if( ierr .ne. -1 ) then
rn » x
else
rn - -9999.
endif
write (*,*) ' Enter Observed mixing height [m] : '
read (*, 5000) clO
ierr » atof (clO,x)
if( ierr .ne. -1 ) then
ziobs - x
else
ziobs - -9999.
endif
write(*,*) ' Enter Base height of cloud ceiling [ftxlOO]:1
CSF00010
CSF00030
CSF00040
CSF00050
CSF00060
CSF00070
CSF00080
CSF00090
CSF00100
CSF00110
CSF00120
CSF00130
CSF00140
CSF00150
CSF00160
CSF00170
CSF00190
CSF00200
CSF00210
CSF00220
CSF00230
CSF00240
CSF00250
CSF00260
CSF00270
CSF00280
CSF00290
CSF00300
. CSF00310
CSF00320
CSF00330
CSF00340
CSF00350
CSF00360
CSF00370
CSF00389—
CSF00390
CSF00400
CSF00410
CSF00420
CSF00430
CSF00440
CSF00450
CSF00460
CSF00470
CSF00480
CSF00490
CSF00500
CSF00510
CSF00520
CSF00530
CSF00540
CSF00550
CSF00560
CSF00570
CSF00580
CSF00590
CSF00600
CSF00610
CSF00620
CSF00630
CSF00640
CSF00650
CSF00660
187
-------
read(*,5000) clO
ierr =* atoi(cio, ix)
if( ierr .ne. -1 ) then
ch - ix
else
ch = -9999
endif
115 write(*,*) ' Enter Cloud cover [tenths]
read(*,5000) clO
ierr - atoi(clO,ix)
if( ierr-.ne. -1 ) then
cc « ix
else
cc = -9
endif
120 call zapchr()
ice - cc
write(*,6000) iyr, imo, idy, ihr, qr, rn, ziobs, ch, ice
write(l,*) iyr, imo, idy, ihr, qr, rn, ziobs, ch, cc
write(*,*)
write(*,*)' Another hour (Y/N) ? '
read(*,5010) c
if(c .eq. 'Y' .or. c .eq. 'y') go to 100
999
5000
5010
6000
C
1
1
1
1
&
&
&
&
&
& ]
(
:all delay
return
format (alO)
format (al)
formate '/
TOTAL
CLOUD ' /
YR MO DY HR SOLAR
COVER1/
L3,i3,i3,i3,llx,f6.1
»nd
INCOMING
RADIATION
[w/m2]
,5x,f6. l,2x,
NET
RADIATION
[w/m2]
f6.1,6x,i4
MIXING " CEILING ' ,
HEIGHT HEIGHT ' ,
[m] [ftxioo]'/
1
6x,il)
CSF00670
CSF00680
CSF00690
CSF00700
CSF00710
CSF00720
CSF00730
CSF00740
CSF00750
CSF00760
CSF00770
CSF00780
CSF00790
CSF00800
CSF00810
CSF00820
CSF00830
CSF00840
CSF00850
CSF00860
CSF00870
CSF00880
CSF00890
CSF00900
CSF00910
CSF00920
CSF00930
CSF00940
CSF00950
CSF00960
CSF00970
CSF00980
CSF00990
CSF01000
CSF01010
CSF01020
CSF01030
CSF01040
CSF0105JT
CSF01060
/&
188
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
105
subroutine crsfc
Program: CRSFC
Purpose: Create a SURF1 input file to METPRO
Assumptions/Limitations :
I/O:
Called By:
Calls:
atof
zapchr
Include Files:
Version: 1.0 Level: 871109
integer atof
character cl
character*lo clO
call zapchr ()
write(*,*) ' Create SURFACE file.1
write ( * , * )
write(*,*)' Enter date info.'
write (*,*)' Enter 2 -digit year: '
readf*,*) iyr
write(*,*)' Enter month [1-12]: '
read(*,*) imo
writa(*,*)' Enter day of month [1-31]: '
read(*,*) idy
write(*,*)' Enter hour [1-24]: '
readf*,*) ihr
write(*,*) ' Enter surface data (Hit RETURN for missing data).1
write (*,*)
write(*,*) ' Observed mixing height [m] : '
read(*,5000) cio
ierr - atof (clO,x)
if( ierr .ne. -1 ) then
ziobs - x
else
ziobs - -9999.
endif
write(*,*) ' Calculated mixing height [m] : '
read (*, 5000) clO
ierr - atof (clO,x)
if( ierr . ne. -1 ) then
zipre - x
else
zipre - -9999.
endif
write(*,*)' Surface Friction Velocity [m/s]: '
read (*, 5000) cio
ierr - atof (clO,x)
if( ierr .ne. -1 ) then
ustar » x
else
ustar - -9999.
endif
write (*,*) ' Monin-Obukhov Length [m] : '
CSC00010
• CSC00020
CSC00030
CSC00040
CSC00050
CSC00060
CSC0007Q
CSC00080
CSC00090
CSC00100
CSC00110
CSC00120
CSC00130
CSC00140
CSC00150
CSC00160
CSC00170
CSC00180
CSC00190
f*^f*n n o f\f\
v»ov»UU^UU
CSC00210
CSC00220
CSC00230
CSC00240
CSC00250
CSC00260
CSC00270
CSC00280
CSC00290
CSC00300
CSC00310
CSC00320
CSC00330
CSC00340
CSC00350
CSC00360
CSC00370
CSC00380
CSC00390~
CSC00400
CSC00410
CSC00420
CSC00430
CSC00440
CSC00450
CSC00460
CSC00470
CSC00480
CSC00490
CSC00500
CSC00510
CSC00520
CSC00530
CSC00540
CSC00550
CSC00560
CSC00570
CSC00580
CSC00590
CSC00600
CSC00610
CSC00620
CSC00630
CSC00640
CSC00650
CSC00660
189
-------
120
read(*,5000) clo
ierr =• atof(clO,x)
if( ierr .ne. -1 ) then
el = x
else
el = -9999.
endif
write(*,*) ' Surface Roughness Length [m]: '
read(*,5000) clO
ierr = atof(clO,x)
if( ierr .ne. -1 ) then
zO = x
else
zO = -9999.
endif
call zapchr()
write(*,6000) iyr, imo, idy, ihr, ziobs, zipre,
ustar, el, zO
call julian(iyr, imo, idy, jcd)
write(1,*) iyr, imo, idy, jcd, ihr, ziobs, zipre,
ustar, el, zO
call delay
write(*,*)' Enter another hour (Y/N) ? '
read(*,'(al)') cl
if(cl .eq. 'Y' .or. cl .eq. 'y') go to 105
]
5000 1
6000 J
&
&
&
&
&
&
& i
return
format (alO)
formate '/
Surface1/
YR MO DAY HR
Roughness ' /
Length ' / ,
L3,i4,i5,U,3x,f6.
Observed
Mixing
Height
I,5x,f6.l,
Predicted
Mixing
Height
3x,f6.3,5x,
Monin- '
Surface Obukhov '
Ustar Length '
f5.2,4x,f6.4)
end
CSC00670
CSC00680
CSC00690
CSC00700
CSC00710
CSC00720
CSC00730
CSC00740
CSC00750
CSC00760
CSC00770
CSC00780
CSC00790
CSC00800
CSC00810
CSC00820
CSC00830
CSC00840
CSC00850
CSC00860
CSC00870
CSC00880
CSC00890
CSC00900
CSC00910
CSC00920
CSC00930
CSC00940
CSC00950
CSC00960
CSC00970
CSC00980
CSC00990
CSC01000
CSC01010
CSC01020
CSC01030
CSC01040
CSC0105TT
190
-------
subroutine delay DLYOOOlO
C DLY00020
c Program: DELAY DLY00030
C DLY00040
c Purpose: Wait-for user to continue program by entering any character DLY00050
C DLY00060
c Assumptions/Limitations: Console has already been opened DLY00070
C DLY00080
c I/O: To console DLY00090
c - DLY00100
c Called By: DLY00110
c DLY00120
c Calls: DLY00130
c DLY00140
c Include Files: DLY00150
c DLY00160
c Version: 1.0 Level: 871109 DLY00170
c DLY00180
DLY00190
character*! a DLY00200
DLY00210
write(*,*) DLY00220
write(*,*) DLY00230
& ' Hit RETURN to continue ' DLY00240
read(*,1,end-2,err-2) a DLY00250
1 format(al) DLY00260
2 return DLY00270
end DLY00280
191
-------
integer function exist(cf)
character*(*) cf
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
Function: axist
Purpose: Check if file exists in current directory,
Assumptions/Limitations:
I/O: None '
Called By: NA-
Calls: None
Include Files:
Version: 1.0 Level: 371109
logical 1
integer NO, YES
data NO/0/, YES/I/
inquire(file-cf,exist-1)
if( 1 ) then
exist-YES
else
exist=NO
endif
return
end
EXI00010
EXI00020
EXI00030
EXI00040
EXI00050
SXI00060
EXI00070
EXI00080
EXI00090
EXI00100
EXI00110
EXI00120
EXI00130
EXI00140
EXI00150
EXI00160
EXI00170
EXI00180
-EXI00190
EXI00200
EXI00210
EXI00220
EXI00230
EXI00240
EXI00250
EXI00260
EXI00270
EXI00280
EXI00290
EXI00300
EXI00310
EXI00320
EXI00330
192
-------
subroutine files FlLOOOlo
C" r~~I~^ FIL00020
c Purpose: List files FIL00030
C FIL00040
c Assumptions: COMMAND.COM must be in path. FIL00050
C FIL00060
c Limitations: Not all FORTRAN?? compilers include the SYSTEM call FIL00070
c in their libraries. FIL00080
c _ FIL00090
c===== character*6 dir FIL00100
c====«= character*26 b FlLOOiio
c===«»=. character*32 com FIL00120
c===»= data dir/'dir/p '/ FIL00130
c=Mmat ca.ll system('CLS') FIL00140
c==*== write(*,*)' Enter file name pattern for command' FIL00150
cssaaa write(*,*)'>dir/p ' FIL00160
Cs«=3« read(*,5) b FIL00170
cs*=== format(a) FIL00180
c=»»»= com - dir // b FIL00190
c====- call system(com) FIL00200
return FIL00210
end FIL00220
193
-------
SUBROUTINE JULIAN(YEAR,MONTH,DAY,JUL) JUL00010
INTEGER YEAR,MONTH,DAY,JUL JUL00020
INTEGER NDAY(12) JUL00030
DATA NDAY/0,31,59,90,120,151,181,212,243,273,304,334/ JUL00040
JUL=NDAY(MONTH)+DAY JUL00050
IF(.NOT.(MONTH.LE.2))GOTO 23000 JUL00060
RETURN JUL00070
23000 CONTINUE JUL00080
IF(.NOT.(MOD(YEAR,4).EQ.O))GOTO 23002 JUL00090
JUL=JUL+1 JUL00100
23002 CONTINUE JUL00110
END JUL00120
194
-------
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
110
subroutine modinp
Program: MODINP. F7 7
Purpose: Modify an existing CTDM input file.
Assumptions/Limitations :
I/O:
Input: Original input file
Output: New input file
Called By: interact
Calls:
stack
recs (10/27/37 pgn modified to take out recs reference)
zapchr
atoi
atof
Include Files:
Version: 1.0 Level: 871109
include ' params . inc '
integer 18(8)
integer atoi, atof
real r5(5), zOhl(MAXHIL)
character*6 varl(8), var2(5)
character* 10 clO
character* 18 ccc(2)
character* 20 chr20
character*80 title
data zOhl/MAXHIL*-999./
data varl/ ' ICASE ' , ' ITOPN ' , ' ICONC ' ,
4 'IMIX ','IWSl ','ISIGV ','IWD ' , ' ICHIQ '/
data var2/'HORIZ ','VERT ','LAT ','LONG ' , 'TZONE '/
data ccc/ ' original Data File1 , 'New Data File '/
run title and program switches
read (1,1000) title
read(l,* ) is
call zapchr ()
write(6,6000) ccc(l), title, is
write (*,*) ' Change title [Yes-1, No-RETURN] ? '
read(*,1005) clO
ierr - atoi(clO, ians)
if(ians .eg. l) then
write (*,*) 'Enter New title'
write(*,*) ' '
read (*, 1000) title
endif
write(*,*)' Change I/O or Program Switches [Yes-1, No-RETURN] ?
read (*, 1005) clO
ierr - atoi (clO, ians)
if (ians .eg. 1) then
write(*,*) ' Hit RETURN to persist value.'
do 100 ij-1,8
write(*,*) ' f,varl(ij),' old value = ',i8(ij),
& ' new value - '
read (*, 1005, err*»loo) clO
MIN00010
MIN00020
MIN00030
MIN00040
MIN00050
MIN00060
MIN00070
MIN00080
MIN00090
MIN00100
MIN00110
MIN00120
MIN00130
MIN00140
MIN00150
MIN00160
MIN00170
MIN00180
MIN00190
MIN00200
MIN00210
MIN00220
MIN00230
MIN00240
-MTwn n *? ^n
WiWU \J 4 OU
MIN00260
MIN00270
MIN00280
MIN00290
MIN00300
MIN00310
MIN00320
MIN00330
MIN00340
MIN00350
MIN00360
MIN00370
MIN00380
MIN00393-
MIN00400
MIN00410
MIN00420
MIN00430
MIN00440
MIN00450
MIN00460
MIN00470
MIN00480
MIN00490
MIN00500
MIN00510
MIN00520
MIN00530
MIN00540
MIN00550
MIN00560
MIN00570
'MIN00580
MIN00590
MIN00600
MIN00610
MIN00620
MIN00630
MIN00640
MIN00650
MIN00660
25"
195
-------
100
c
c
c
120
c
c
c
&
&
&
ierr = atoi(clO,ians)
if( ierr .eq. -i ) go to 100
if(ij .eg. 3) then
if(ians .ne. 0 .and.
ians .ne. 1 .and.
ians .ne. 2 .and.
ians .ne. 3 ) then
write(*,*) ' Invalid input ',
1 Try Again ! ! ! '
go to 110
else
i8(ij) = ians
endif
else if(ians .ne. 0 .and. ians .ne. 1) then
write(*,*) ' Invalid input Try Again !
go to 110
else
i8(ij) = ians
endif
continue
call zapchr()
write(6,6000) ccc(2), title, i8
endif
write(2,1000) title
write(2,1010) is
call delay
read misc program constants
read(l,*) r5, ipol
call zapchr()
write(6,6010) ccc(l), r5 , ipol
write(*,*)' Modify Misc Program Constants [Yes«l, No-RETURN] ?
read(*,1005) clO
ierr - atoi(clO,ians)
if( ians .eq. 1 ) then
write(*,*)' Hit RETURN to persist value. '
do 120 ij-1,5
write(*,*) ' ',var2(ij),' old value - ',r5(ij),
1 new value - '
read(*,1005) clO
ierr - atof( clO, xx )
if( ierr .eq. -l ) go to 120
r5(ij) - xx
continue
write(*,*)' IPOL, old value » ',ipol,' new value » '
read(*,1005) clO
ierr - atoi( clO, ix )
if( ierr .ne. -1 ) ipol - ix
call zapchr()
writ*(6,6010) ccc(2), r5, ipol
call delay
endif
write(2,1020) r5, ipol
read tower coords
call zapchrQ
read(l,1050) chr20,xt,yt,zt
write(2,2040) chr20,xt,yt,zt
write(6,6070) chr20,xt,yt,zt
call delay
call stack
call recs
(10/27/87)
MIN00670
MIN00680
MIN00690
MIN00700
MIN00710
MIN0072Q
MIN00730
MIN00740
MIN00750
MIN00760
MIN00770
MIN00780
MIN00790
MIN00800
•MIN00810
MTN00820
MIN00830
MIN00840
MIN00850
MIN00860
MIN00870
MIN00880
MIN00890
MIN00900
MIN00910
MIN00920
MIN00930
MIN00940
MIN00950
MIN00960
MIN00970
MIN00980
'MIN00990
MIN01000
MIN01010
MIN01020
MIN01030
MIN01040_
MIN01050
MIN01060
MIN01070
MIN01080
MIN01090
MIN01100
MIN01110
MIN01120
MIN01130
MIN01140
MIN01150
MIN01160
MIN01170
MIN01180
MIN01190
MIN01200
MIN01210
MIN01220
MIN01230
MIN01240
MIN01250
MIN01260
MIN01270
MIN01280
MIN01290
MIN01300
MIN01310
MIN01320
196
-------
c
c
c
210
220
230
240
&
250
&
&
260
280
1000
1005
1010
1020
&
1030
1040
1050
2000
2010
2020
2030
2040
2050
5000
5010
6000
&
&
&
read hill roughness lengths
read(l,*,end-210) zOhl
do 220 i-l,MAXHIL
if(zOhl(i) .eq. -999.) go to 230
continue
nhl = i-1
call zapchr()
write (*,.*) ' Hill Surface Roughness Lengths, zO '
write(*,*) ' Hill Number zO [m] '
do 240 nh=l,nhl
write (*, 6080) nh,zohl(nh)
continue
write (*,*) ' Do you want to modify any of these values',
1 [Yes=l, No=RETURN] ? '
read(*,1005) clO
ierr - atoi(clO, ians)
if(ians .eg. 1) then
write(*,*) ' Enter hill number or hit RETURN to1,
1 continue: '
read(*,1005) clO
ierr « atoi(clo,nh)
if(nh .eq. 0 .or. ierr .eq. -1) go to 260
if(nh .gt. nhl) go to 250
write(*,*) ' Enter new zO value for hill number ',
' : '
read(*,*) zzOO
zOhl(nh) - zzOO
go to 250
endif
continue
call zapchrQ
write (*,*) ' New Hill Surface Roughness Lengths, zO '
write(*,*) ' Hill Number zO [m] '
do 280 nh-l,nhl
write(*,6080) nh,zOhl(nh)
continue
call delay
write(2,2050) (zOhl(nh) ,nh-l,nhl)
return
format(asO)
format (alO)
format (12, 6( ' , ' ,12) , • , ' , 12)
1 , M2)
format (4a4 , 3a7 , 5f 7 . o , 7x, il)
format (4a4,4x,4f 10. 0,i5)
format (a20 , 3 f 10 . Oj
format ( 4a4 , 3a7 , f 7 . 2 , f 7 . 3 , f 7 . 1 , f 7 . 3 , f 7 . 2 , i8 )
format ( ' ENDS ' )
format ( 4a4 , 4x, 2f 10 . 4 , 2f 10 . 2 , i5)
format ( ' ENDR • )
format(a20,3fl0.3)
format(8f!0.4)
format(flO.O)
format (15)
formate ',al8,//' ',a80//
1 I/O Switches'/
1 I CASE: Case Study Printout [0»No, l«Yes]
1 ITOPN: Printout TOP N Table ro-No, 1-Yesl
MIN01330
MIN01340
MIN01350
MIN01360
MIN01370
MIN01380
MIN01390
MIN01400
MIN01410
MIN01420
MIN01430
MIN01440
MIN01450
MIN01460
MIN01470
MIN01480
MIN01490
MIN01500
MIN01510
MIN01520
MIN01530
MIN01540
MIN01550
MIN01560
MIN01570
MIN01580
nh, MIN01590
MIN01600
MIN01610
MIN01620
MIN01630
MIN01640
MIN01650
MIN01660
MIN01670
MIN01680
MIN01690
MIN01700
MIN0171U-
MIN01720
MIN01730
MIN01740
MIN01750
MIN01760
MIN01770
MIN01780
MIN01790
MIN01800
MIN01810
MIN01820
MIN01830
MIN01840
MIN01850
MIN01860
MIN01870
MIN01880
MIN01890
MIN01900
MIN01910
MIN01920
MIN01930
MIN01940
MIN01950
MIN01960
1 , i2/MIN01970
. ' ,i2/MIN01980
197
-------
6010
6070
6080
&
&
&
f.
&
5
&
&
&
&
&
£
&
g,
&
5
&
&
&
1 ICONC: Concentration Output [0=No, l=Binary, 2/3=Text] ...',
/' Internal Program Switches'/
1 IMIX: Mixing Hts [0=Off-site first, l=On-site first]....
1 IWS1: Minimum Wind Speed 1 m/s [0=No, l=Yes] ,
1 ISIGV: Horiz Turb Intensity [b=Sigma-Theta, l=Sigma-V] . . . . '
1 IWD: Scale Wind Direction with Height [0=No,l=Yes] .... ,
1 ICHIQ: Concentration Units [o=Chi, l=Chi/Q] ,
formate ',al3,//,
1 Miscellaneous Program Constants '/,
' HORIZ:- Horizontal Scale Factor, User Units to Meters ...',
f7.4/
i VERT* "Vertical Scale Factor User Units to Meters ' ,
f7.4/
i LAT: Latitude [deg] ' ,
f7.3/
1 LONG: Longitude ' ,
f7.3/
1 TZONE* Time Zone Hours behind GMT ( + if West) '
f2.0/
• ipoL: Pollutant Number '
format(/' Meteorological Tower Coordinates:1//' ' ,a20,3f 10.4)
format(i9,fl4.4)
end
12/MIN01990
MIN02000
i2/MIN02010
12/MIN02020
12/MIN02030
12/MIN02040
12/MIN02050
MIN02060
MIN02070
MIN02080
MIN02090
MIN02100
MIN02110
MIN02120
MIN02130
MIN02140
MIN02150
MIN02160
, MIN02170
MIN02180
, MIN02190
MIN02200
MIN02210
MIN02220
MIN02230
198
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
15
subroutine modopt
Subroutine: MODOPT
Purpose: Modify existing OPTIONS input file to METPRO.
Assumptions/Limitations :
I/O:
Called By:
Calls
Include Files:
Version: 1.0 Level: 871109
real xlat, xlon, zO, al, br
integer atof, atoi, ientry, itz
integer NO, YES
character c
character*10 clO
data NO/0/, YES/ I/
call zapchrQ
ientry - NO
write (*,*) ' Modify OPTIONS file.1
write (*,*) ' '
read(l,*) icase
if(icase .ne. 0) then
write ( * , * ) ' ERROR '
write(*,*)' File is NOT a CASE mode input file!1
writa(*,*)' CAUTION: Check directory for partially1,
& ' created OPTIONS file. '
STOP ' Program Terminating Execution1
endif
read(l,*) xlat, xlon, itz, zO, al, br
write(*,6000) xlat, xlon, itz, zO, al, br
write(*,*)
write (*,*)' Modify any of these values [Y/N] ? '
read(*, ' (al) •) c
entry entopt ( ientry , exlat , exlon , ietz , ezO , ea 3, , ebr )
if (ientry .eq. YES) then
c - 'Y'
xlat - exlat
xlon * exlon
itz - ietz
zO - ezO
al - eal
br - ebr
endif
0 if(c .eq. 'Y' .or. c .eq. 'y') then
write(*,*)' Hit RETURN to persist any value.'
write(*,*) ' Latitude ',xlat, ' [deg] . New value ? '
read (*, 5000) clO
ierr - atof(clO,x)
if( ierr .ne. -l ) then
if(x .ge. -90. .and. x . le. 90.) xlat= x
endif
write(*,*) ' Longitude ',xlon,' [deg]. New value ? '
read (*, 5000) clO
ierr - atof(clO,x)
MOP00010
\ff^ n A A rt T rt
~ MOP00020
MOP00030
MOP00040
MOP00050
MOP00060
MOP00070
MOP00080
MOP00090
MOP00100
MOP00110
MOP00120
MOP00130
MOP00140
MOP00150
MOP00160
MOP00170
MOP00190
MOP00200
MOP00210
MOP00220
MOP00230
MOP00240
MOP00250
MOP00260
MOP00270
MOP00280
MOP00290
MOP00300
MOP00310
MOP00320
MOP00330
MOP00340
MOP00350
MOP00360
MOP00370
MOP00380
MOP0039TT
MOP00400
MOP00410
MOP00420
MOP00430
MOP00440
MOP00450
MOP00460
MOP00470
MOP00480
MOP00490
MOP00500
MOP00510
MOP00520
MOP00530
MOP00540
MOP00550
MOP00560
MOP00570
MOP00580
MOP00590
MOP00600
MOP00610
MOP00620
MOP00630
MOP00640
MOP00650
MOP00660
199
-------
x .le. 180.) xlon= x
New Value ? '
ix .le. 12 ) itz = ix
endif
if( ierr .ne. -1 ) then
if(x .ge. -180. .and.
endif
write(*,*) ' Time Zone ',itz,'
read(*,5000) clO
ierr = atoi(c!0,ix)
if( ierr .ne. -1 ) then
if(ix .ge. -12 .and.
endif
write(*,*) ' Surface Roughness Length ',zO,' [m]1,
1 New Value ? '
read(*,5000) clO
-ierr = atof(clO,x)
if( ierr .ne. -1 ) then
zO = x
endif
write(*,*) ' Albedo ',al,' New Value ? '
read(*,5000) clO
ierr - atoffclO, x)
if( ierr .ne. -1 ) then
if(x .ge. 0.0 .and. x .le. 1.0) al = x
endif
write(*,*) ' Bowen Ratio ',br,' New Value ? '
read(*,5000) clO
ierr - atof(clO, x)
if( ierr .ne. -1 ) then
if(x .ge. 0.0) br =» x
endif
if(ientry .eq. YES) then
exlat - xlat
exlon - xlon
ietz - itz
ezO - zO
eal - al
ebr - br
return
endif
call zapchrQ
write(*,6000) xlat, xlon, itz, zO, al, br
write(*,*)» Inputs OK ? [Y/N]:'
read(*,•(al)') c
if(c .eq. 'N' .or. c .eq. 'n') then
c - 'Y'
go to 150
endif
write(2,*) lease
write(2,*j xlat, xlon, itz, zO, al, br
OPTIONS FILE - CASE STUDY MODE'//
Latitude: ',f7.3,' [deg]'/
Longitude: ',f7.3,' [deg]'/
Time Zone: ',i2,/
Surface Roughness Length: ',f5.2,
Albedo: ',f5.2,/
Bowen Ratio: ',f5.2,/)
999 <
]
5000 J
6000
&
&
&
&
&
&
&
:all delay
return
format (alO)
format (' '/
MOPQQ670
MOP00680
MOP00690
MOP00700
MOP00710
MOP00720
MOP00730
MOP00740
MOP00750
MOP00760
MOP00770
MOP00780
MOP00790
MOP00800
MOP00810
MOP00820
MOP00830
MOP00840
MOP00850
MOP00860
MOP00870
MOP00880
MOP00890
MOP00900
MOP00910
MOP00920
MOP00930
MOP00940
MOP00950
MOP00960
MOP00970
MOP00980
MOP00990
MOP01000
MOP01010
MOP01020
MOP01030
MOP01040
Cm]'/
end
MOP01060
MOP01070
MOP01080
MOP01090
MOP01100
MOP01110
MOP01120
MOP01130
MOP01140
MOP01150
MOP01160
MOP01170
MOP01180
MOP01190
MOP01200
MOP01210
MOP01220
MOP01230
MOP01240
MOP01250
MOP01260
MOP01270
MOP01280
MOP01290
200
-------
subroutine modpro
c Program : MODPRO
c
c Purpose: Allows user to interactively modify a "PROFILE" input file
c
c Assumptions/Limitations:
c - all files have already been opened
c
c I/O:
c - screen^ (console) quiz user
c - unit 1 PROFILE file to be modified
c - unit 2 new PROFILE file
c
c Called By:
c
c Calls:
c
c Include Files:
c
c Version: 1.0 Level: 871109
include ' pararas . inc '
include 'profil.cmn1
integer no, yes
integer atoi, atof
real sigth(MAXLEV)
character cl
character*lo clO
data no/0/, yes/l/
100 nh - 0
110 nh - nh + 1
read(l,*,end-999) jyr, jmo, jdy, jhr, ht(nh) , iend, wdhr(nh) ,
s wshr(nh), tahr(nh) , sigth(nh) , swhr(nh)
& uvhr(nh)
if (iend .eq. YES) go to 120
go to 110
120 call zapchr()
write(6,6000) jmo, jdy, jyr, jhr
do 130 n-l,nh
if( mod(n,15) .eq. l .and. n .ne. 1 ) then
call delay
call zapchrQ
write(6,6001) jmo, jdy, jyr, jhr
endif
writ«(6,6010) n, ht(n), wdhr(n) , wshr(n) , uvhr(n),
4 tahr(n), sigth(n), swhr(n)
130 continue
131 write(*,*)' Modify (M) , Insert (I), Append (A), Continue ',
& ' (RETURN) '
132 write(*,*)' Enter [M, I, A, RETURN]:1
read(*, ' (al) ',err-132) cl
if( cl .eq. 'M' .or. cl .eq. 'm1 ) go to 135
if( cl .eq. 'I' .or. cl .eq. 'i' ) go to 200
if( cl .eq. 'A1 .or. cl .eq. 'a' ) go to 220
if( cl .eq. ' ' .or. cl .eq. ' ' ) go to 400
write(*,*) ' Invalid Input! Try Again.1
go to 131
c
MPR00010
UDD A n n ~i r\
— MPROOU2U
MPR00030
MPR00040
. MPR00050
MPR00060
MPR00070
MPR00080
MPR00090
MPR00100
MPR00110
MPR00120
MPR00130
MPR00140
MPR00150
MPR00160
MPR00170
MPR00180
MPR00190
MPR00200
MPR00210
MPR00230
MPR00240
MPR00250
MPR00260
MPR00270
MPR00280
MPR00290
MPR00300
MPR00310
MPR00320
MPR00330
MPR00340
MPR00350
MPR00360
,MPR00370_
MPR00380
MPR00390
MPR00400
MPR00410
MPR00420
MPR00430
MPR00440
MPR00450
MPR00460
MPR00470
MPR00480
MPR00490
MPR00500
MPR00510
MPR00520
MPR00530
MPR00540
MPR00550
MPR00560
MPR00570
MPR00580
MPR00590
MPR00600
MPR00610
MPR00620
MPR00630
MPR00640
MPR00650
"31
201
-------
c
c
135
Modify Levels
write(*,*) ' Enter level number you wish to change.1
write(*,*) ' Hit RETURN to continue.'
read(*,5009) clO
ierr = atoi(clO,l)
if( ierr .eq. -1 ) go to 400
if(l .gt. 0 .and. 1 .le. nh) then
write(*,*)' Hit RETURN to persist value.1
write(*,*)' Enter -999 for missing data.1
write(*,*) ' Height = ',ht(l)
write(*,*) ' Wind Direction old value =
wdhr(l),1 new value = '
read(*,5000) clO
ierr = atof(clO,x)
if( ierr .eq. -1 ) go to 140
if(x .It. 0.0) then
wdhr(l) * -999.0
if(x .le. 360.0) then
wdhr(l) « x
140
150
160
170
else
else
write(*,*)' Invalid wind direction, ',
1 persisting old value
endif
write(*,*) ' Scalar wind Speed old value • '
wshr(l),' new value = '
read(*,5000) clO
ierr =« atof(clo,x)
if( ierr .eq. -1 ) go to 150
if(x .It. 0.0) x - -999.0
wshr(l) - x
write(*,*) ' Vector Wind Speed old value = '
uvhr(l),' new value * '
read(*,5000) clO
ierr = atof(clO,x)
if( ierr .eq. -l ) go to 160
if( x .It. 0.0) then
uvhr(l) =• -999.0
else if(wshr(l) .gt. 0.0) then
if(x .le. wshr(l)) then
uvhr(l) - x
else
else
endif
uvhr(l)
write(*,*)' Vector wind speed
'greater than scalar '
'wind speed, therefore
' vector set to scalar
uvhr(l) - wshr(l)
180
endif
write(*,*) ' Temperature old value
tahr(l) , ' new value =• '
read(*,5000) clo
ierr - atof(clO,x)
if( ierr .eq. -1 ) go to 170
if( x .It. 0.0) x - -999.0
tahr(l) - x
write(*,*) ' Sigma-Theta old value
sigth(l),' new value - '
read(*,5000) clO
ierr - atof(clo,x)
if( ierr .eq. -1 ) go to 180
if( X .It. 0.0) x - -999.0
sigth(l) - x
write(*,*) ' Sigma-W old value
MPR00660
MPR00670
MPR00680
MPR00690
MPR00700
MPR00710
MPR00720
MPR00730
MPR00740
MPR00750
MPR00760
, MPR00770
MPR00780
MPR00790
MPR00800
MPR00810
MPR00820
MPR00830
MPR00840
MPR00850
MPR00860
MPR00870
'MPR00880
MPR00890
, MPR00900
MPR00910
MPR00920
MPR00930
MPR00940
MPR00950
MPR00960
MPR00970
MPR00980
MPR00990
MPR01000
MPR01010
MPROL020
MPR01030~
MPR01040
MPR01050
MPR01060
MPR01070
,MPR01080
MPR01090
,MPR01100
'MPR01110
MPR03.120
MPR01130
MPR01140
MPR01150
MPR01160
MPR01170
MPR01180
MPR01190
MPR01200
MPR01210
MPR01220
MPR01230
MPR01240
MPR01.250
MPR01260
MPR01270
MPR01.280
MPR01290
MPR01300
MPR01310
202
-------
& swhr(l),' new value = '
read(*,5000) clo
ierr = atof(clO,x)
if( ierr .eg. -1 ) go to 190
if( X .It. 0,0) x = -999.0
swhr(l) = x
190 continue
end if
go to 120
c Enter new Level
200 write(*,*)' Insert new level before level # ',
& '(Hit RETURN to continue)'
read(*,5000) clO
ierr » atoi(clO,l)
if( ierr .eq. -1) go to 120
if(l .le. 0 .or. 1 .gt. nh .or. ierr .eq. -1) then
write(*,*) 'Invalid Level! Try Again.1
go to 200
endif
do 210 n-nh,l,-l
ht(n+l) - ht(n)
wdhr(n+l) - wdhr(n)
wshr(n+l) - wshr(n)
tahr(n+l) - tahr(n)
sigth(n+l) - sigth(n)
swhr(n+l) - swhr(n)
uvhr(n+l) » uvhr(n)
210 continue
new - 1
go to 230
220 new « nh + 1
230 nh - nh + 1
240 write(*,*)' Enter new height [m]: '
read(*,*) ht(new)
if(new .It. nh) then
if(ht(new) .ge. ht(new+l)) then
write(*,*)' Height is higher than next level!1
go to 240
endif
endif
if(new .gt. l) then
affht(new) .le. ht(new-l)) then
write(*,*)' Height is less than previous level!
go to 240
endif
endif
write(*,*) ' New profile data (missing - -999.0)'
250 write(*,*)' Enter new wind direction [deg]: '
read(*,*) wdhr(new)
iffwdhr(new) .gt. 360.0) then
write(*,*)' Invalid wind direction! Try Again.'
go to 250
endif
write(*,*)' Enter new scalar wind speed [m/sl: '
read(*,*) wshr(new)
260 write(*,*)' Enter new vector wind speed [m/s]: '
read(*,*) uvhr(new)
MPR01320
MPR01330
MPR01340
MPR01350
MPR01360
MPR01370
MPR01380
MPR01390
MPR01400
MPR01410
MPR01420
MPR01430
MPR01440
MPR01450
MPR01460
MPR01470
MPR01480
MPR01490
MPR01500
MPR01510
MPR01520
MPR01530
MPR01540
MPR01550
MPR01560
MPR01570
MPR01580
MPR01590
MPR01600
MPR01610
MPR01620
MPR01630
MPR01640
MPR01650
MPR01660
MPR01670
MPR01680
MPR01690
MPR01700-
MPR01710
MPR01720
MPR01730
MPR01740
MPR01750
MPR01760
MPR01770
MPR01780
MPR01790
'MPR01800
MPR01810
MPR01820
MPR01830
MPR01840
MPR01850
MPR01860
MPR01870
MPR01880
MPR01890
MPR01900
MPR01910
MPR01920
MPR01930
MPR01940
MPR01950
MPR01960
MPR01970
33
203
-------
if(uvhr(new) .gt. wshr(new) .and. wshr(new) .ge. 0.0) then MPR01980
write(*,*)' Vector wind speed greater than scalar wind1,MPF01990
270
400
410
999
5000
6000
6001
6010
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
&
1 speed! '
go to 260
endif
write {*,*)' Enter new temperature [deg-K] : '
read(*,*) tahr(new)
write (*,-*)' Enter new sigma-theta [deg] : '
read (*,*') sigth(new)
if (sigth^(new) .gt. 103.9) then
write(*,*)' Sigma-Theta too large!'
go to 270
endif
write(*,*)' Enter new sigma-w [m/s]: '
read(*,*) swhr(new)
go to 120
iend * NO
do 410 n»l,nh
if(n .eq. nh) iend » YES
if(wdhr(n) .It. 0.0) wdhr(n) - -999.0
if(wshr(n) .It. 0.0) wshr(n) « -999.0
if(tahr(n) .It. 0.0) tahr(n) - -999.0
if(sigth(n) .It. O.O)sigth(n) = -999.0
if(swhr(n) .It. 0.0) swhr(n) - -999.0
if(uvhr(n) .It. 0.0) uvhr(n) - -999.0
write(2,*) jyr, jmo, jdy, jhr, ht(n), iend,
wdhr(n) , wshr(n), tahr(n) ,
sigth(n) , swhr(n) , uvhr(n)
continue
go to 100
return
format (alO)
format (' Meteorological Profile Data ',
i2,V',i2,'/1/i2,' Hour:',i3,/
1 Level Wind --Wind Speed— Ambient Sigma
/
1 f Height Dir Scalar Vector Temp Theta
/
' [m] [deg] [m/s] [m/s] [deg-K] [deg]
)
formate Meteorological Profile Data ',
i2, V»i2, '/'/i2, ' Hour:',i3,' cont. '/
1 Level Wind — Wind Speed — Ambient Sigma
/
1 f Height Dir Scalar Vector Temp Theta
/
' [m] [deg] [m/s] [m/s] [deg-K] [deg]
)
format(i6,f9.1,3x,f5.1,2(3x,f5.2) , 3x, f 6.2,2 (2x, f 5.2) )
end
MPR02000
MPR02010
MPR02020
MPR02030
MPR02040
MPR02050
MPR02060
MPR02070
MPR02080
MPR02090
MPR02100
MPR02110
MPR02120
MPR02130
MPR02140
MPR02150
MPR02160
MPR02170
MPRCI2180
MPR02190
MPR02200
MPR02210
MPR02220
MPR02230
MPR02240
MPR02250
MPR02260
MPR02270
MPR02230
MPR02290
MPR02300
MPR02310
MPR02320
MPR02330
MPR02340
MPR0235J3L
MPR02360
MPR02370
MPR02380
Sigma 'MPR02390
MPR02400
W 'MPR02410
MPR02420
[m/s] 'MPR02430
MPR02440
MPR02450
MPR02460
Sigma 'MPR02470
MPR02480
W 'MPR02490
MPR02500
[m/s] 'MPR02510
MPR02520
MPR02530
MPR02540
204
-------
subroutine modsfl
c Program: MODSF1
c
c Purpose: Modify an existing SURF1 input file to METPRO.
c
c Assumptions/Limitations:
c
c I/O:
c
c Called By:
c
c Calls
c
c Include Files:
c
c Version: 1.0 Level: 871109
integer atof, atoi
integer ch, cc
character c
character*10 clO
Jckount « 0
100 read(l,*,end-999) iyr, imo, idy, ihr, qr, rn, ziobs, ch, cc
kkount • Jckount + 1
105 call zapchr()
ice - cc
write(*,6000) iyr, imo, idy, ihr, qr, rn, ziobs, ch, cc
write (*,*)
110 write(*,*) ' Modify (M) , Continue (RETURN): '
read(*, ' (al) ') c
if( c .eg. ' ' ) go to 120
if( c .eq. 'M1 .or. c .eq. 'm1 ) then
write (*,*) ' To persist value Hit RETURN1
write(*,*) ' Missing Data - -999.'
write(*,*) ' Total incoming solar radiation ',qr,
& ' [w/m2] new value ? '
read(*,5000) clO
ierr - atof(clO,x)
if( ierr .ne. -1 ) then
qr - x
endif
write(*,*)' Net radiation ',rn,' [w/m2] ',
& ' new value ? '
read(*,5000) clO
ierr - atof(clO,x)
if( ierr .ne. -1 ) then
rn - x
endif
write(*,*) ' Observed mixing height ', ziobs,1 [m] ',
& ' new value ? '
read (*, 5000) clO
ierr - atof (clO,x)
if( ierr .ne. -1 ) then
ziobs - x
endif
write(*,*) ' Base height of cloud ceiling ',ch,
& ' [ftxlOO] new value ? '
read(*,5000) clO
ierr - atoi(clO,ix)
if( ierr .ne. -1 ) then
ch - ix
endif
MSF00010
MSF00030
MSF00040
MSF00050
MSF00060
MSF00070
MSF00080
MSF00090
MSF00100
MSF00110
MSF00120
MSF00130
MSF00140
MSF00150
MSF00160
MSF00170
MSF00190
MSF00200
MSF00210
MSF00220
MSF00230
MSF00240
MSF00250
MSF00260
MSF00270
MSF00280
MSF00290
MSF00300
MSF00310
MSF00320
MSF00330
MSF00340
MSF00350
MSF00360
MSF00370
MSF00389-
MSF00390
MSF00400
MSF00410
MSF00420
MSF00430
MSF00440
MSF00450
MSF00460
MSF00470
MSF00480
MSF00490
MSF00500
MSF00510
MSF00520
MSF00530
MSF00540
MSF00550
MSF00560
MSF00570
MSF00580
MSF00590
MSF00600
MSF00610
MSF00620
MSF00630
MSF00640
MSF00650
MSF00660
205
-------
115
120
999
9999
5000
6000
&
&
&
&
&
&
&
&
else
write(*,*) ' cloud cover ', cc,' [tenths]
1 new value ? '
read(*,5000) clO
ierr = atoi(clO,ix)
if( ierr .ne. -1 ) then
cc = ix
endif
go to 110
endif
go to 105
call zapchr()
ice « cc
write(*,6000) iyr, imo, idy, ihr, gr, rn, ziobs, ch,
write(2,*) iyr, imo, idy, ihr, gr, rn, ziobs, ch, cc
go to 100
ice
iffkkount .gt. 0) go to 9999
write(*,*)' SURF1 file EMPTY
stop
call delay
return
format(alO)
formate '/
CLOUD'/
YR MO DY HR
COVER1/
TOTAL INCOMING
SOLAR RADIATION
[w/m2]
Fatal Error 1
NET MIXING
RADIATION HEIGHT
[w/m2] [m]
i3, i3, i3, i3,14x, f 6.1,5x, f 6.1,2x, f 6.1,6x, i4, 6x, il)
end
MSF00670
MSF00680
MSF00690
MSF00700
MSF00710
MSF00720
MSF00730
MSF00740
MSF00750
MSF00760
MSF00770
MSF00780
MSF00790
MSF00800
MSF00810
MSF00820
MSF00830
MSF00840
MSF00850
MSF00860
MSF00870
MSF00880
MSF00890
MSF00900
MSF00910
MSF00920
MSF00930
MSF00940
HEIGHT1,MSF00950
MSF00960
[ftxlOO]'/MSF00970
•,MSF00980
MSF00990
MSF01000
MSF01010
CEILING1
206
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
100
105
110
subroutine modsfc
Program:
Purpose:
Assumptions/Limitations :
I/O:
Called By:
Calls
Include Files:
Version: 1.0 Level: 871109
integer atof, atoi
character c
character* 10 clO
read(l, *,end*999) iyr, imo, idy, jcd, ihr, ziobs, zipre,
& ustar, el, zO
call zapchr()
write(*,6000) iyr, imo, idy, ihr, ziobs, zipre,
& ustar, el, zO
write (*,*)
write(*,*) ' Modify (M) , Continue (RETURN): '
read(*, ' (al) ') c
iff c .eg. ' ' ) go to 120
if( c .eq. .'M1 .or. c .eq. 'm1 ) then
write (*,*) • To persist value Hit RETURN1
write(*,*) ' Missing Data - -999.'
write(*,*) ' Observed mixing height ', ziobs,1 [ra] ',
& ' new value ? '
read(*,5000) clO
ierr - atof(clO,x)
if( ierr .ne. -1 ) then
ziobs * x
else if( x .It. 0.0 ) then
ziobs » -9999.
endif
write(*,*) ' Calculated mixing height ', zipre,1 [m] ',
& ' new value ? '
read (*, 5000) clO
ierr - atof (clO,x)
if( ierr .ne. -1 ) then
zipre - x
else if( x .It. 0.0 ) then
zipre - -9999.
endif
write(*,*)' Surface Friction Velocity ', ustar, ' [m/s]
& ' new value ? '
read(*,5000) clO
ierr - atof (clO,x)
if( ierr .ne. -1 ) then
ustar « x
else if( x .It. -100. ) then
ustar » -9999.
endif
write (*,*) ' Monin-Obukhov Length ', el,1 [m] ',
& ' new value ? '
read(*,5000) clO
MSC00010
MSC00030
MSC00040
MSC00050
MSC00060
MSC00070
MSC00080
MSC00090
MSC00100
MSC00110
MSC00120
MSC00130
MSC00140
MSC001.50
MSC00160
MSC00170
MSC00190
MSC00200
MSC00210
MSC00220
MSC00230
MSC00240
MSC00250
MSC00260
MSC00270
MSC00280
MSC00290
MSC00300
MSC00310
MSC00320
MSC00330
MSC00340
MSC00350
MSC00360
MSC00370
MSC00380
MSC00390
MSC00400
MSC00410
MSC00420
MSC00430
MSC00440
MSC00450
MSC00460
MSC00470
MSC00480
MSC00490
MSC00500
MSC00510
MSC00520
MSC00530
MSC00540
1 ,MSC005SO
MSC00560
MSC00570
MSC00580
MSC00590
MSC00600
MSC00610
MSC00620
MSC00630
MSC00640
MSC00650
MSC00660
207
-------
else
ierr - atof(clo,x)
if( ierr .ne. -1 ) then
el = x
else if( x .It. -100. ) then
el = -9999.
end if
write(*,*) ' Surface Roughness Length
1 new value ? '
jread(*,5000) clO
ierr = atof(clO,x)
if( ierr .ne. -1 ) then
zO = x
else if( x .It. -100. ) then
Z0 » -9999.
endif
20,' [a] ',
go to 110
endif
go to 105
120 call zapchr()
write(*,6000) iyr, imo, idy, ihr, ziobs, zipre,
& ustar, el, zO
write(2,*) iyr, imo, idy, jcd, ihr, ziobs, zipre,
& ustar, el, zO
go to 100
999 C
1
5000 1
6000 1
&
f
&
&
&
&
&
&
& .
:all delay
return
format (alO)
format ( ' ' /
Surface ' /
YR MO DAY HR
Roughness ' /
Length ' / ,
[m] '//,
L3,i4,l5,i4,4x,f6.
Observed
Mixing
Height
[m]
I,5x,f6.1
Predicted
Mixing
Height
[m]
3x, f6.3,4x,
Surface
Ustar
[m/s]
f5.2,4x,
Monin- '
ObuJchov '
Length '
[m] •
f6.4)
t
t
r
9
end
MSC00670
MSC00680
MSC00690
MSC00700
MSC00710
MSC00720
MSC00730
MSC00740
MSC00750
MSC00760
MSC00770
MSC00780
MSC00790
MSC00800
MSC00810
MSC00820
MSC00830
MSC00840
MSC00850
MSC00860
MSC00870
MSC00880
MSC00890
MSC00900
MSC00910
MSC00920
MSC00930
MSC00940
MSC00950
MSC00960
MSC00970
MSC00980
MSC00990
MSC01000
MSC01010
MSC01020
MSC01030
MSC0104XT
MSC01050
MSC01060
MSC01070
MSC01080
208
-------
subroutine modter
c Program: modter. for
c
c Purpose: Modify a TERRAIN input file.
c
c Assumptions/Limitations:
c
c I/O:
c read original file
c write new file
c
c Called By: modinp
c
c Calls:
c zapchr
c atof
c
c Include Files:
c
c Version: 1.0 Level: 871109
include ' params . inc '
include 'hill.cmn1
real zh(MAXHIL)
integer atoi, atof
character cl
character*10 clO
nhl - 0
100 read(l, 1000, end-900 ) nh, nz, htp, (hilnam(i,nhl+l) , i»l, 10)
nhl * nhl + 1
do 110, n»l,nz
read (1,10 10, end-999,err=999) zh(n) ,xhw(n,nh) ,yhw(n,nh) ,
4 majorw(n,nh) ,majaxw(n,nh) ,minaxw(n,nh)
110 continue
do 112 n-l,nz
read(l,1020,end-999,err*999) zh(n) ,xhl(n,nh) ,yhl(n,nh) ,
& majorl(n,nh) ,expoma(n,nh) ,expomi(n,nh) ,
& scalma(n,nh) ,scalmi(n,nh)
112 continue
114 call zapchr ()
write(*,6020) nh, (hilnam(i,nh) ,i-l,10) , htp-
do 116 n"»l,nz
MTR00010
MTC A f\ f\ O rt
MIKU(J(J2 0
MTR00030
MTR00040
MTR00050
MTR00060
MTR00070
MTR00080
MTR00090
MTR00100
MTR00110
MTR00120
MTR00130
MTR00140
MTR00150
MTR00160
MTR00170
MTR00180
MTR00190
MTR00200
MTR00210
MTO f\ f\ o ^ n
"WiKUU^^U
MTR00230
MTR00240
MTR00250
MTR00260
MTR00270
MTR00280
MTR00290
MTR00300
MTR00310
MTR00320
MTR00330
MTR00340
MTR00350
MTR00360
MTR00370
MTR0038»-
MTR00390
MTR00400
MTR00410
MTR00420
MTR00430
MTR00440
MTR00450
MTR00460
MTR00470
116
120
200
if(mod(n,15) .eq. 1) write(*,6030) (hilnam(i,nh),i-l,10)MTR00480
if(mod(n,15) .eq. 1 .and. n .ne. 1) call more MTR00490
write(*,6040) zh(n),xhw(n,nh),yhw(n,nh),majorw(n,nh), MTR00500
majaxw(n,nh),minaxw(n,nh) MTR00510
continue MTR00520
MTR00530
write(*,*)' Modify (M) or Continue (RETURN): ' MTR00540
read(*,5000) cl MTR00550
if(cl .eq. 'M1 .or. cl .eq. 'm') go to 200 MTR00560
if(cl .eq. ' ') go to 300 MTR00570
write(*,*)'
go to 120
write(*,*)
Invalid Input
Try Again.
Enter height of level to be modified,
•or hit RETURN to continue: '
read(*,5010) clO
ierr - atof(clO,xl)
if(ierr .eq. -1) go to 120
do 202 n-l,nz
MTR00580
MTR00590
MTR00600
MTR00610
MTR00620
MTR00630
MTR00640
MTR00650
MTR00660
209
-------
202
206
ixl = nint(xl)
izh = nint(zh(n))
if(ixl .eq. izh) go to 206
continue
write(*,*) ' Invalid Height ! Try Again.',ixl,izh
go to 114
Try Again.
1 = n
if(l .It, 1 .or. 1 .gt. nz) then
write(*,*) ' Invalid Level Number !
go to 200
endif
210 continue
c write(*,*)' Contour Height ',zh(l),' New Value? '
c read(*,5010) clO
c ierr = atof(clO,x)
c if(ierr .eq. -1) go to 220
c if(l .gt. 1) then
c if(x .gt. zh(l-l)) then
c zh(l) = x
c else
c write(*,*)' Height is below previous level !'
c go to 210
c endif
c endif
c if(l .It. nh) then
c if(x .It. zh(l-t-l)) then
c zh(l) » x
c else
c write(*,*)' Height is above next level !'
c go to 210
c endif
c endif
220 write(*,*)' x-Coord of Wrap Hill Center ',xhw(l,nh),
& ' New Value: '
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 230
xhw(l,nh) - x
230 write(*,*)' Y-Coord of Wrap Hill Center ',yhw(l,nh),
& ' New Value: '
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 240
yhw(l,nh) «• x
240 write(*,*)' Major Axis Azimuth from North ',majorw(l,nh),
& ' New Value: '
read(*,5010) clO
ierr - atof(c!0,x)
if(ierr .eq. -1) go to 250
majorw(l,nh) - x
250 write(*,*)' Major Ellipse Axis Length ',majaxw(l,nh),
& ' New Value: '
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 260
majaxw(l,nh) - x
260 write(*,*)' Minor Ellipse Axis Length ',minaxw(l,nh),
read(*,5010) clO
New Value:
MTR00670
MTR00680
MTR00690
MTR00700
MTR00710
MTR00720
MTR00730
MTR00740
MTR00750
MTR00760
MTR00770
MTR00780
MTR00790
MTR00800
MTR00810
MTR00820
MTR00830
MTR00840
MTR00850
MTR00860
MTR00870
MTR00880
MTR00890
MTR00900
MTR00910
MTR00920
MTR00930
MTR00940
MTR00950
MTR00960
MTR00970
MTR00980
MTR00990
MTR01000
MTR01010
MTR01020
MTR01030_
MTR01040
MTR01050
MTR01060
MTR01070
MTR01080
MTR01090
MTR01100
MTR01110
MTR01120
MTR01130
MTR01140
MTR01150
MTR01160
MTR01170
MTR01180
MTR01190
MTR01200
MTR01210
MTR01220
MTR01230
MTR01240
MTR01250
MTR01260
MTR01270
MTR01280
MTR01290
MTR01300
MTR01310
MTR01320
210
-------
ierr = atof(clo,x)
if(ierr .eq. -1) go to 114
minaxw(l,nh) = x
go to 114
300 call zapchr()
write(*,6020) nh, (hilnam(i,nh),i=l,10), htp
do 310 n=l,nz
if(mod(n,15) .eq. 1) write(*,6050) (hilnam(i,nh),i=i
if(mod(n,15) .eq. 1 .and. n .ne. 1) call more
write(*,6060) zh(n),xhl(n,nh),yhl(n,nh),majorl(n,nh)
& ' expoma(n,nh),expomi(n,nn),
& . scalma(n,nh),scalmi(n,nh)
310 continue
320 write(*,*)' Modify (M) or Continue (RETURN): '
read(*,5000) cl
if(cl .eq. 'M1 .or. cl .eq. 'm') go to 400
if(cl .eq. ' ') go to 500
write(*,*)' Invalid Input ! Try Again '
go to 320
400 write(*,*) ' Enter height of level to be modified, ',
& 'or hit RETURN to continue: '
read(*,5010) clO
ierr - atof(clO,xl)
if(ierr .eq. -1) go to 320
do 402 n-l,nz
ixl * nint(xl)
izh - nint(zh(n))
if(ixl .eq. izh) go to 406
402 continue
write(*,*) ' Invalid Height ! Try Again.',ixl,izh
go to 300
406 1 - n
410 continue
c write(*,*)' Contour Height ',zh(l),' New Value? '
c read(*,5010) clO
c ierr » atof(clO,x)
c if(ierr .eq. -l) go to 220
c if(l .gt. 1) then
c if(x .gt. zh(l-l)) then
c zh(l) - x
c else
c write(*,*)' Height is below previous level !
c go to 410
c endif
c endif
c if(l .It. nh) then
c if(x .It. zh(H-l)) then
c zh(l) - x
c else
c write(*,*)' Height is above next level !'
c go to 410
c endif
c endif
420 write(*,*)' x-Coord of Lift Hill Center ',xhl(l,nh),
& ' New Value: '
read(*,5010) clO
ierr - atof(c!0,x)
if(ierr .eq. -1) go to 430
xhl(l,nh) - x
430 write(*,*)' Y-Coord of Wrap Lift Center ',yhl(l,nh),
& ' New Value: '
MTR01330
MTR01340
MTR01350
MTR01360
MTR01370
MTR01330
MTR01390
MTR01400
,10)MTR01410
MTR01420
, MTR01430
MTR01440
MTR01450
MTR01460
MTR01470
MTR01480
MTR01490
MTR01500
MTR01510
MTR01520
MTR01530
MTR01540
MTR01550
MTR01560
MTR01570
MTR01580
MTR01590
MTR01600
MTR01610
MTR01620
MTR01630
MTR01640
MTR01630
MTR01660
MTR01670
MTR01680
MTR01690
MTR01700
MTR0171fl_
MTR01720
MTR01730
MTR01740
MTR01750
MTR01760
' MTR01770
MTR01780
MTR01790
MTR01800
MTR01810
MTR01820
MTR01830
MTR01840
MTR01850
MTR01860
MTR01870
MTR01880
MTR01890
MTR01900
MTR01910
MTR01920
MTR01930
MTR01940
MTR01950
MTR01960
MTR01970
MTR01980
211
-------
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 440
yhl(l,nh) = x
440 write(*,*)' Major Axis Azimuth from North ',majorl(l,nh),
& ' New Value: '
read(*,5010) clo
ierr - atof(clO,x)
if(ierr .eq. -1) go to 450
majorl(l,nh) = x
450 write(*,*)' Major Ellipse Inverse Polynomial Exponent ',
& expoma(1,nh),' New Value: '
read(*,5010) clO
ierr = atof(clO,x)
if(ierr .eq. -1} go to 460
expoma(l,nh) = x
460 write(*,*)' Minor Ellipse Inverse Polynomial Exponent ',
& expomi(l,nh),' New Value: '
read(*,5010) clO
ierr - atof(clo,x)
if(ierr .eq. -1) go to 470
expomi(l,nh) - x
470 write(*,*)' Major Ellipse Inverse Polynomial Scale Factor
& scalma(1,nh),' New Value: '
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 480
scalma(l,nh) - x
480 write(*,*)' Minor Ellipse Inverse Polynomial Scale Factor
& scalmi(l,nh),' New Value: '
read(*,5010) clO
ierr - atof(clO,x)
if(ierr .eq. -1) go to 300
scalmi(l,nh) - x
go to 300
500 write(2,2000) nh, nz, htp, (hilnam(i,nhl+l),1-1,10)
do 510, n»l,nz
write(2,2010) zh(n),xhw(n,nh),yhw(n,nh),
& majorw(n,nh),majaxw(n,nh),minaxw(n,nh)
510 continue
do 520 n-l,nz
write(2,2020) zh(n),xhl(n,nh),yhl(n,nh),
& majorl(n,nh),expoma(n,nh),expomi(n,nh),
& scalma(n,nh),scalmi(n,nh)
520 continue
go to 100
900 return
999 write(*,*) ' ERROR READING TERRAIN FILE !'
write(*,*) ' Consult Documentation. !'
return
1000 format(5x,i2,Ix,i2,lOx,f10.0,10X,10a4)
1010 format(6flO.O)
1020 format(8flO.O)
2000 format(5x,i2,Ix,i2,lOx,f10.0,lOx,I0a4)
2010 format(fl0.3,2el0.4,3fl0.3)
MTR01990
MTR02000
MTR02010
MTR02020
MTR02030
MTR02040
MTR02050
MTR02060
MTR02070
MTR02080
MTR02090
MTR02100
MTR02110
MTR02120
MTR02130
MTR02140
MTR02150
MTR02160
MTR02170
MTR02180
MTR02190
MTR02200
MTR02210
MTR02220
MTR02230
MTR02240
MTR02250
MTR02260
MTR02270
MTR02280
MTR02290
MTR02300
MTR02310
MTR02320
MTR02330
MTR02340
MTR02350
MTR0236TT
MTR02370
MTR02380
MTR02390
MTR02400
MTR02410
MTRCI2420
MTR02430
MTR02440
MTR02450
MTR02460
MTR02470
MTR02480
MTR02490
MTR02500
MTR02510
MTR02520
MTR02530
MTR02540
MTR02550
MTR02560
MTR02570
MTR02580
MTR02590
MTR02600
MTR02610
MTR02620
MTR02630
MTR02640
212
-------
2020
5000
5010
6020
6030
6040
6050
format(f!0.3 , 2el0.4 ,5fl0.3)
format (al)
format (alO)
FORMAT(/' HILL*', 12,' ', 10A4 , 'HILL TOP: ', F7 . 1,
' (USER UNITS) ')
FORMAT(/' BEST FIT ELLIPSE INFORMATION FOR WRAP: ',10A4,/
1 CONTOUR X-COORD Y-COORD MAJOR AXIS ELLIPSE AXIS
' LENGTHS-! , / ,
1 HEIGHT (HILL CENTER) A2IM. FROM N MAJOR
'MINOR' ,/,
FORMAT(F9.1,2F10.3,F11.1,2X,2F11.3)
FORMAT (/' He CUT-OFF HILL INFORMATION FOR LIFT: ',10A4,/,
' CONTOUR X-COORD Y-COORD MAJOR AXIS ---- INVERSE ' ,
1 POLYNOMIAL VARIABLES ---- ' , / ,
1 HEIGHT (HILL CENTER) AZIM. FROM N MAJ EXP MIN EXP
•MAJ SCALE MIN SCALE',/,
6060
FORMAT(F9.1,F10.3,F9.3,F10.1,Fll.3,F8.3,F12.3,Fll.3)
end
MTR02650
MTR02660
MTR02670
MTR02680
MTR02690
MTR02700
MTR02710
MTR02720
MTR02730
MTR02740
MTR02750
MTR02760
MTR02770
MTR02780
MTR02790
MTR02800
MTR02810
MTR02820
MTR02830
MTR02840
MTR02850
MTR02860
MTR02870
MTR02880
213
-------
subroutine more MOROOOlo
C MOR00020
c Program: DELAY MOR00030
G MOR00040
c Purpose: Wait for user to continue program by entering any character MOR00050
c MOR00060
c Assumptions/Limitations: Console has already been opened MOR00070
c MOR00080
c I/O: To console MOR00090
c 7 MOR00100
c Called By: MOR00110
c - MOR00120
c Calls: MOR00130
c MOR00140
c Include Files: MOR00150
C MOR00160
c Version: 1.0 Level: 871109 MOR00170
c MOR00180
MOR00190
character*! a MOR00200
MOR00210
write(*,*) MOR00220
write(*,*) MOR00230
& ' More (Hit RETURN to continue) 'MOR00240
read(*,l,end-2,err-2) a MOR00250
1 format(al) MOR00260
2 return MOR00270
end MOR00280
214
-------
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
subroutine newfle(unit,name)
Program: NEWFLE
Purpose: Open existing disk file
Assumptions/Limitations: Max file name length 16 characters
I/O:
Called By:
Calls:
Include Files:
Version: 1.0 Level: 871109
integer unit
character*! c
character*16 name
100
write(*,*) « '
write(*,*) ' Enter file name:1
read(*,500,err=100,end»100) name
close(unit)
open(unit, file-name, status='new', err=110)
go to 130
110
120
130
500
write(*,*) '
write(*,*) '
read(*,'(al) ') c
if( c .eq. 'Q1 .or.
go to 100
write(*,*)
return
format(a!6)
end
Error opening ',name
Retry (R) or Quit (Q) ?'
c .eq. 'q') STOP 'Bye Bye1
NEW00010
• NEW00020
NEW00030
NEW00040
NEW00050
NEW00060
NEW00070
NEWOOOSO
NEW00090
NEW00100
NEW00110
NEW00120
NEW00130
NEW00140
NEW00150
NEW00160
NEW00170
-NEW00180
NEW00190
NEW00200
NEW00210
NEW00220
NEW00230
NEW00240
NEW00250
NEW00260
NEW00270
NEW00280
NEW00290
NEW00300
NEW00310
NEW00320
NEW00330
NEW00340
NEW00350
NEW00360
NEW00370
NEW0038.Q_
NEW00390
NEW00400
NEW00410
215
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
100
110
120
130
140
500
subroutine oldfle(unit, name)
Program: OLDFLE
Purpose: Open existing disk file
Assumptions/Limitations: Max file name length 16 characters
I/O:
Called By:
Calls:
Include Files:
Version: 1.0 Level: 871109
integer unit
character*! c
character* 16 name
character* 16 blank
data blank/1 '/
write(*,*) ' '
write(*,*) ' Enter file name:1
read (*, 500, err»100,end-100) name
close (unit)
open(unit, file»narae, status='old' , err=110 )
go to 140
write (*,*) ' I am sorry, I cannot find that file ',name
write (*,*) ' Return to previous menu (R) , or1
write(*,*)' Enter NEW file name (N) ?'
read(*, ' (al) ') c
if( c . eq. 'R1 .or. c .eq. 'r') go to 130
if( c .eq. 'N1 .or. c .eq. 'n1) go to 100
go to 120
name - blank
return
format (a!6)
end
OLD00010
OLD00030
OLD00040
OLD00050
OLD00060
OLD00070
OLD00080
OLD00090
OLD00100
OLD00110
OLD00120
OLD00130
OLD00140
OLD00150
OLD00160
OLD00170
OLD00190
OLD00200
OLD00210
OLD00220
OLD00230
OLD00240
OLD00250
OLD00260
OLD00270
OLD00280
OLD00290
OLD00300
OLD00310
OLD00320
OLD00330
OLD00340
OLD00350
OLD00360
OLD00370_
OLD00380
OLD00390
OLD00400
OLD00410
OL000420
OLD00430
OL000440
OLD00450
216
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
10
c
20
30
subroutine putdot(s, n)
Subroutine: putdot
Purpose: Insert a decimal point and right justify a real number
has read into a character string
Assumptions/Limitations :
- Does not handle bad input at all
Arguments :
s chr*(*) character string containing numbers
n int length of character string
I/O: None
Called By: NA
Calls: None
Include Files: None
Version: 1.0 Level: 871109
character* (*) s
integer n, i
look for either decimal point or end of number string
iflag - 0
do 10 i-l,n
if( s(i:i) .ge. '0' .and. s(i:i) .le. '9' ) then
iflag = l
else if( s(i:i) .eg. '.' ) then
go to 20
else if( s(i:i) .eq. ' ' ) then
if( iflag .eq. 1 ) then
s (i : i) • '.'
go to 20
endif
else
go to 20
endif
continue
right justify
do 30 i * n, 2, -1
if( s(i:i) .eg. ' ') then
il - I - 1
s(i:i) » s(il;il)
•(iiiil) - • '
endif
continue
return
end
DOT00010
DOT00030
DOT00040
that DOT00050
DOT00060
DOT00070
DOT00080
DOT00090
DOT00100
DOT00110
DOT00120
DOT00130
DOT00140
DOT00150
DOT00160
DOT00170
DOT00180
DOT00190
DOT00200
DOT00210
DOT00220
DOT00230
DOT00250
DOT00260
DOT00270
DOT00280
DOT00290
DOT00300
DOT00310
DOT00320
DOT00330
DOT00340
DOT00350
DOT00360
DOT00370
DOT0038TT
DOT00390
DOT00400
DOT00410
DOT00420
DOT00430
DOT00440
DOT00450
DOT00460
DOT00470
DOT00480
DOT00490
DOT00500
DOT00510
DOT00520
DOT00530
DOT00540
DOT00550
DOT00560
217
-------
subroutine recs
c Subroutine: RECS.F77
c
c Purpose:
c
c Assumptions/Limitations:
c
c I/O:
c Input: Original input file
c Output: New input file
c
c Called By:
c
c Calls:
c
c Include Files:
c
c Version: 1.0 Level: 871109
include ' params . inc '
include ' recept . cmn '
integer atoi, atof
character cl
character*10 clO
c
c read receptor information
c
nr - 0
100 nr » nr + l
read(l,1040,end=105) (rname(i,nr) ,1-1,4) ,
& (recpt(j,nr) , j-1,4) ,nrhill(nr)
go to 100
105 continue
nrecpt - nr - 1
110 call zapchr()
write (*, 6050)
do 120 nr-1, nrecpt
if( mod(nr,15). eq. 1 .and. nr. gt. 1) then
call more
call zapchr()
write(*,6050)
endif
write(*,6060) nr, (rname(i,nr) ,1*1,4) ,
& (recpt(j,nr),j-l,4),nrhill(nr)
120 continue
150 write(*,*)' Modify (M) , Append (A), Delete (D) , ',
& 'Continue (RETURN):1
read(*, ' (al) ') cl
if(cl .eq. 'M1 .or. cl .eq. 'm') go to 200
if(cl .eq. 'D1 .or. cl .eq. 'd') go to 300
if(cl .eq. 'A1 .or. cl ,eq. 'a') go to 400
if(cl .eq. ' ' ) go to 500
200 write (*,*) ' Enter receptor number you wish to modify: '
read(*,*) nr
write (*,*) ' Receptor Number: ',nr
write(*,*) ' Hit RETURN to persist value.1
write (*,*) ' X-Coord » ' ,recpt(l,nr) , ' new value ? '
read (*, 1005) clO
ierr - atof ( clO, x )
REC00010
REC00030
REC00040
REC00050
REC00060
REC00070
REC00080
REC00090
REC00100
REC00110
REC00120
REC00130
REC00140
REC00150
REC00160
REC00170
REC00180
REC00190
REC00210
REC00220
REC00230
REC00240
REC00250
REC00260
REC00270
REC00280
REC00290
REC00300
REC00310
REC00320
REC00330
REC00340
REC00350
REC00360
REC00370
REC0038TT
REC00390
REC00400
REC00410
REC00420
REC00430
REC00440
REC00450
REC00460
REC00470
REC00480
REC00490
REC00500
REC00510
REC00520
REC00530
REC00540
REC00550
REC00560
REC00570
REC00580
REC00590
REC00600
REC00610
REC00620
REC00630
REC00640
REC00650
REC00660
218
-------
if( ierr .eq. -1 ) go to 210
recpt(l,nr) = x
210 write(*,*) ' Y-Coord = ',recpt(2,nr),' new value ? '
read(*,1005) clO
ierr = atof( clO, x )
if( ierr .eq. -1 ) go to 220
recpt(2,nr) = x
220 write(*,*) ' Receptor height above ground = ',
& recpt(3,nr), ' [m] new value ?
read(*,1305) clO
ierr * atof( clO, x )
if( ierr .eq. -1 ) go to 230
recpt(3,nr) = x
230 write(*,*) ' Receptor ground elevation = ',
& recpt(4,nr), ' [m] new value ? '
read(*,1005) clO
ierr =» atof( clO, x )
if( ierr .eq. -1 ) go to 240
recpt(4,nr) =» x
240 write(*,*) ' Receptor is on Hill Number ',
& nrhill(nr), ' new hill number ? '
read(*,1005) clO
ierr - atoi( clO, ix )
if( ierr .eq. -1 ) go to 250
nrhill(nr) - ix
250 call zapchr()
write(*,*)' Modified Receptor Data1
write(*,*)' '
write(*,6050)
write(*,6060) nr,(rname(i,nr),i-l,4),
* .fc , (recpt(j,nr),j=l,4),nrhill(nr)
writef*,*)
write(*,*) ' Change other receptor data ? '
go to 150
300 write(*,*)« Enter receptor number to be deleted. '
read(*,ioo5) clO
ierr - atoi(clO,nr)
if(ierr .eq. -1) go to 150
if(nr .ge. 1 .and. nr .le. nrecpt) then
write(*,*)' Receptor to be deleted.'
write(*,*)
write(*,6050)
write(*,6060) nr,(rname(i,nr),i-l,4),
& (recpt(j,nr),j«l,4),nrhill(nr)
nrecpt - nrecpt - i
do 320 n-nr,nrecpt
do 310 i-1,4
rname(i,n) - rname(i,n+l)
,,n . recpt(i,n) - recpt(i.n-t-l)
310 continue
nrhill(n) - nrhill(n-i-l)
320 continue
endif
go to 150
400 nr - nrecpt + 1
if(nr .gt. MAXREC) then
write(*,*)' Maximum number of receptors exceeded]'
else
nrecpt - nr
write(*,*)' New Receptor # ',nr
write(*,*)' Receptor Name: '
read(*,'(4a4)') (rname(i,nr),i-1,4)
write(*,*)' X-Coordinate: '
read(*,*) recpt(l,nr)
REC00670
REC006SO
REC00690
REC00700
REC00710
REC00720
REC00730
REC00740
REC00750
REC00760
REC00770
REC00730
REC00790
REC00800
REC00810
REC00820
REC00830
REC00840
REC00850
REC00860
REC00870
REC00380
REC00890
REC00900
REC00910
REC00920
REC00930
REC00940
REC00950
REC00960
REC00970
REC00980 '
REC00990
REC01000
REC01010
REC01020
REC01030
REC01040
REC01050
REC01060
REC01070
REC01080
REC01090
REC01100
REC01110
REC01120
REC01130
REC01140
REC01150
REC01160
REC01170
REC01180
REC01190
REC01200
REC01210
REC01220
REC01230
REC01240
REC01250
REC01260
REC01270
REC01280
REC01290
REC01300
REC01310
REC01320
219
-------
writef*,*)1 Y-Coordinate: '
read(*,*) recpt(2,nr)
write(*,*)' Height above ground: '
read(*,*) recpt(3,nr)
write(*,*)' Ground Elevation: '
read(*,*) recpt(4,nr)
write(*,*)' Hill Number: '
read(*,*} nrhill(nr)
call zapchr()
write(*,6050)
write(*,6060) nr,(rname(i,nr),i=l,4),
& (recpt(j,nr),j=l,4),nrhill(nr)
end if
go to 110
500 do 510 nr=l,nrecpt
write(2,2020) (rname(i,nr),i=l,4),(recpt(j,nr),j=
& nrhill(nr)
510 continue
550 call zapchrQ
write(*,6050)
do 560 nr~l,nrecpt
if( mod(nr,15). eq. 1 .and. nr. gt. 1) then
call more
call zapchr()
write(*,6050)
end if
write(*,6060) nr,(rname(i,nr),i»l,4),
& (recpt(j,nr),j-l,4),nrhill(nr)
560 continue
call delay
return
1005 format(alO)
1040 format(4a4,4x,4flO.O,i5)
2020 format(4a4,4x,2fl0.4,2£10.2,i5)
2030 f onnat (' ENDR •)
6050 FORMAT(27X,'FIXED RECEPTOR INFORMATION1,//,
* ' REC IDENTIFICATION EAST NORTH HEIGHT ABOVE
* 'GRD LVL1,/,
1 NO. COORD COORD LOCAL GRD LVL
•ELEVATION HILL',/,
1 (USER UNITS) "(USER UNITS)
1(USER UNITS) NUMBER',/,
1 -')
6060 FORMAT(I4,2X,4A4,1X,F9.3,F9.3,5X,F7.1,5X,F7.1,7X,I2)
end
REC01330
REC01340
REC01350
REC01360
REC01370
REC01380
REC01390
REC01400
REC01410
REC01420
REC01430
REC01440
REC01450
REC01460
REC01470
REC014SO
REC01490
REC01500
REC01510
REC01520
REC01530
REC01540
REC01550
REC01560
REC01570
REC01580
REC01590
REC01600
REC01610
REC01620
REC01630
REC01640
REC01650
REC01660
REC01670
REC01680
REC01690
REC0170V
REC01710
REC01720
REC01730
REC01740
REC01750
REC01760
REC01770
REC01780
REC01790
REC01800
REC01810
REC01820
REC01830
220
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
subroutine setpre
Program: setpre
Purpose: Setup inputs, outputs and run stream for METPRO program.
Assumptions/Limitations :
Called By:
MAIN
Calls:
crpro - create profile file from scratch
cropt - create options file from scratch
crsfl - create surfl file from scratch
modpro - modify an existing profile file
modopt - modify an existing options file
modsfl - modify an existinf surfl file
exist - check if file exists
oldfle - open existing file
renme - renames filel to fileZ
zapchr - prints control character to screen
Version: 1.0 Level: 871109
integer exist, iexl, iex2, iex3
integer YES
character c
character*16 nname, oname, blank
data YES/ I/
data blank/1 '/
call zapchr ()
write (*, 6000)
6000 format (////
& METPRO - The CTDM Meteorological Preprocessor Program1//
4 The following data files are required: '//,
* - OPTIONS1//
& - PROFILE1/,
& - SURFl'///,
4 The current status of these files is:1//1 ')
iexl - exist ('OPTIONS')
if (iexl .eq. VES) then
writef*,*)1 The OPTIONS file currently exists.
else
write (*,*)' The OPTIONS file does not exist.1
endif
iex2 - exist (' PROFILE ')
if(iex2 .eq. YES) then
write (*,*)' The PROFILE file currently exists.
else
write(*,*)« The PROFILE file does not exist.1
endif
iex3 - exist ('SURF1')
if(iex3 .eq. YES) then
write(*,*)' The SURFl file currently exists.1
else
write(*,*)' The SURFl file does not exist.'
endif
call delay
call zapchr ()
if (iexl .eg. YES) then
write (*, 6666)
write(*,*)' Modify existing OPTIONS file (M) , '
SET00010
cvr^nnnTrt
• O&1UUU2U
SET00030
SET00040
SET00050
SET00060
SET00070
SET00080
SET00090
SET00100
SET00110
SET00120
SET00130
SET00140
SET00150
SEl'00160
SET00170
SET00180
SET00190
SET00200
SET00210
SET00220
SET00230
SET00240
SET00260
SET00270
SET00280
SET00290
SET00300
SET00310
SET00320
SET00330
SET00340
SET00350
SET00360
SET00370
SET003Sn~
SET00390
SET00400
SET00410
SET00420
SET00430
SET00440
'SET00450
SET00460
SET00470
SET00480
SET00490
SET00500
'SET00510
SET00520
SET00530
SET00540
SET00550
SET00560
SET00570
SET00580
SET00590
SET00600
SET00610
SET00620
SET00630
SET00640
SET00650
,SET00660
221
-------
read(*,'(al)'} c
if(c .eg. 'M' .or.
write(*,*)' '
write(*,*)
or Continue (RETURN):
' m') then
.eq.
Rename the existing OPTIONS file
" ,status='OLD')
100
Enter M,
Enter M,
N,
N,
R,
R,
D, or Q:
or Q: '
.eq. 'm') then
c .eq.
go to 100
r') then
open(1,file='OPTIONS'
call newfle(2,nname)
call delay
call modopt
call swnaroe('OPTIONS',nname)
endif
else
write(*,6666)
write(*,6661)
==*write (*, *) '
write(*,*)'
read(*,'(al)') c
if(c .eq. 'M1 .or. c
call oldfle(l,oname)
i£(oname .eq. blank) go to 100
open(2,file-'OPTIONS',status='NEW•)
call modopt
else if(c .eq. 'R' .or
call oldfle(l,oname)
if(onane .eq. blank)
write(3,3000) oname
else if(c .eq. 'N1 .or
open(1,file-'OPTIONS
call cropt
else if(c .eq. 'D'
call files
call delay
call zapchrQ
go to 100
else if(c .eq. 'Q1
go to 9999
else
go to 100
endif
endif
call zapchr()
if(iex2 .eq. YES) then
write(*,6666)
write(*,*)' Modify existing PROFILE file (M),',
1 or Continue (RETURN): '
readf*,'(al)•) c
if(c .eq. 'M1 .or. c .eq. 'm') then
open(1,file-'PROFILE',status-'OLD')
write(*,*)' Rename existing PROFILE file.1
call newfle(2,nname)
call modpro
call swname('PROFILE',nname)
• or.
c .eq.
,status9
: .eq.
'n') then
'NEW•)
1d') then
.or. c .eq. 'q') then
200
else
endif
write(*,6666)
write(*,6662)
write(*,*)' Enter M,
write(*,*)' Enter M,
read(*,'(al)') c
if(c .eq. 'M1 .or. c .eq. 'm') then
.. call oldfle(l,oname)
if(oname .eq. blank) go to 200
open(2,file-'PROFILE',status-'NEW')
call modpro
else if(c .eq. 'R* .or. c .eq. 'r') then
R,
D, or Q:
or Q:'
SET00670
SET00680
SET00690
SET00700
'SET00710
SETOQ720
SET00730
SET00740
SET00750
SET00760
SET00770
SET00780
SET00790
SET00800
SET00810
SET00820
SET00830
SET00840
SET00850
SET00860
SET00870
SET00380
SET00890
SET00900
SET00910
SET00920
SET00930
SET00940
SET00950
SET00960
SET00970
SET00980
SET00990
SET01000
SET01010
SET01020
SET01030
SET01040
SET01050~
SETOL060
SET01070
SETOL080
SETOL090
SET01100
SET01110
SET01120
SET01130
SET01140
SET01150
SET01160
SET01170
SET01180
SET01190
SET01200
SET01210
SET01220
SET01230
SET01240
SET01250
SET01260
SET01270
SET01280
SET01290
SET01300
SET01310
SET01320
222
-------
. or. c .eq. 'd') then
C=
C-
.or.
c .eq. 'q') then
call oldfle(l,oname)
if(oname .eq. blank) go to 200
write(3,3010) oname
else if(c .eq. 'N' .or. c .eq. 'n') then
open(1,file-'PROFILE',status='NEW')
call crpro
»==« else if(c .eq. 'D
====== call files
call delay
===== call zapchr ()
===== go to 200
else if(c .eq. 'Q
go to 9999
else
go to 200
fandif
endif
call zapchr()
if(iex3 .eg. YES) then
write(*,6666)
write(*,*)' Modify existing SURF1 file (M),'
1 or Continue (RETURN): '
read(*,'(al)') c
if(c .eq. 'M' .or. c .eq. 'm') then
write(*,*)' '
write(*,*)' Rename existing SURF1 file.
open(1,f ile='SURF1',status='OLD')
call newfle(2,nname)
call delay
call modsfl
call swname('SURF1',nname)
300
c-
else
endif
'm') then
write(*,6666)
write(*,6663)
write(*,*)'
write(*,*)'
read(*,'(al)') c
if(c .eq. 'M' .or. c .eq
call oldfle(l,oname)
if(oname .eq. blank) go to 300
open(2,file-'SURF1',status-'NEW')
call modsfl
else if(c .eq. 'R1 .or. c .eq. 'r') then
call oldfle(l,oname)
if(oname .eq. blank) go to 300
writ*(3,3020) oname
else if(c .«q. 'N1 .or. c .eq. 'n1) then
open(1,file-'SURF1',status-'NEW•)
call crsfl
Enter M, N, R, D, or Q:
Enter M, N, R, or Q:'
endif
iex4
iexs
else if(c .eq. '0'
call files
call delay
call zapchr()
go to 300
else if(c .eq. 'Q1
go to 9999
else
?O to 300
f
.or. c .eq. 'd') then
,or. c .eq. 'q') then
exist('OUTPUT')
exist('SURFACE')
SET01330
SET01340
SET01350
SET01360
SET01370
SET01380
SET01390
SET01400
SET01410
SET01420
SET01430
SET01440
SET01450
SET01460
SET01470
SET01480
SET01490
SET01500
SET01510
SET01520
SET01530
,SET01540
SET01550
SET01560
SET01570
SET01580
'SET01590
SET01600
SET01610
SET01620
SET01630
SET01640
SET01650
SET01660
SET01670
SET01680
SET01690
SET01709-
SET01710
SET01720
SET01730
SET01740
SET01750
SET01760
SET01770
SET01780
SET01790
SET01800
SET01810
SET01820
SET01830
SET01340
SET01850
SET01860
SET01870
SET01880
SET01890
SET01900
SET01910
SET01920
SET01930
SET01940
SET01950
SET01960
SET01970
SET01980
223
-------
401
call zapchr()
if(iex4 .eg. YES) then
write(*,6666)
write (*, *) '
write (*,*) '
read(*, ' (al)
METPRO output file OUTPUT exists,
Delete (D) , or Rename (R) :
if(c .eg. 'D
else
400
c
.or.
write(3,*)' DEL
it(c .eg. 'R'
write(*,*;
c . eq.
OUTPUT
or. c .eg
Rename
d') then
else
Enter new file name
read(*,'(a!6)') nname
iexx - exist(nname)
if( iexx .eg. YES ) go to
write(3,*)' Rename OUTPUT
r1) then
OUTPUT, ',
400
', nname
go to 401
405
410
end if
if(iexS
endif
.eg. YES) then
write(*,*)'
write(*,*}'
read(*,'(al)') c
if(c .eg. 'D' .or.
wr£te(3,*)' DEL
else if(c .eg. 'R'
write(*,*)'
METPRO
output
Delete
file
(D) ,
SURFACE exists,
or Rename (R)
'd') then
•r1) then
SURFACE, ',
new filename:
endif
else
endif"
write(3,*)'
call zapchrQ
write(*,6666)
write(*,*)'
call delay
9999
c
3000
3010
3020
6661
6662
&
&
&
&
&
•4
&
&
&
format('RENAME
format (' RENAME
format('RENAME
format(
format(
SET01990
SET02000
SET02010
'SET02020
'SET02030
SET02040
SET02050
SET02060
SET02070
SET02080
SET02090
SET02100
SET02110
SET02120
SET02130
SET02140
SET02150
SET02160
SET02170
SET02180
SET02190
'SET02200
'SET02210
SET02220
SET02230
SET02240
SET02250
SET02260
SET02270
SET02280
SET02290
SET02300
SET02310
SET02320
SET02330
SET02340
SET02350
SET0236TT
SET02370
SET02380
SET02390
'SET02400
SET02410
SET02420
SET02430
SET02440
SET02450
SET02460
SET02470
SET02480
SET02490
SET02500
SET02510
SET02520
SET02530
SET02540
OPTIONS file does not exist. Do you want to:'//SET02550
- Use an existing file to create OPTIONS (M)'/SET02560
The existing file is left unchanged'/SET02570
- Rename an existing file (R)'/ SET02580
- Create a new OPTIONS file (N)'/ SET02590
- Execute DOS Directory command (D)'/ " SET02600
- Quit (Q)'/) SET02610
SET02620
PROFILE file does not exist. Do you want to:1// SET02630
- Use an existing file to create PROFILE (M)'/SET02640
c .eg.
SURFACE
or. c .eg
Rename
1 Enter
read(*,'(a!6)') nname
iexx - exist(nname)
if( iexx .eg. YES ) go to 410
write(3,*)' Rename SURFACE ',nname
go to 405
METPRO'
Setup for METPRO execution complete.
->
return
write(*,6666)
write(*,*)' - + - * - INTERACT Program Terminating - * - +
write(*,*)' CAUTION: Check the files you have manipulated to1
write(*,*)' ensure that all changes have been ',
1 incorporated'
stop
,a,
,a,
OPTIONS')
PROFILE')
SURF1•)
224
-------
6663
&
&
&
&
&
6666
format(
The existing file is left unchanged'/SET02650
- Rename an existing file (R)'/ SET02660
- Create a new PROFILE file (N)'/ SET02670
- Execute DOS Directory command (D)'/ SET02680
- Quit (Q)'/) SET02690
SET02700
SURF1 file does not exist. Do you want to:'// SET02710
- Use an existing file to create SURF1 (M)'/SET02720
The existing file is left unchanged'/SET02730
format(//////)
end
- Rename an existing file (R)'/
- Create a new SURF1 file (N)'/
- Execute DOS Directory command (D)'/
- Quit (Q)'/)
SET02740
SET02750
SET02760
SET02770
SET02730
SET02790
225
-------
subroutine stack
c Program: stack. F77
c
c Purpose:
c
c Assumptions/Limitations:
c
c I/O:
c Input: Original input file
c Output: New input file
c
c Called By:
c
c Calls:
c
c Include Files:
c
c Version: 1.0 Level: 871109
include ' params . inc '
include ' stacks . cmn '
integer atoi, atof, NO, YES
character cl
integer ends
character*? chr7x(MAXSOR) , chr7y(MAXSOR) , chr7z(MAXSOR)
character*10 clo
data NO/0/, YES/ I/
data ends/4HENDS/
c
c read stack data
c
ns - 0
100 ns = ns + 1
read(l, 1030) (sname(i,ns) , i=l,4) ,chr7x(ns) ,chr7y(ns) ,chr7z(ns) ,
& (source( j ,ns) , j=4,8) , ivar(ns)
if( sname(l,ns) .eg. ends ) go to 120
go to 100
120 continue
nstack « ns - 1
130 call zapchr()
write (6, 6030)
do 140 ns»l, nstack
write(*, 6040) ns, (sname(i,ns) , i=l, 4) , source(8,ns) ,
4 chr7x(ns), chr7y(ns), (source( j ,ns) , j»4,7)
140 continue
write (*,*) ' •
160 write(*,*)f Modify (M) , Add (A), Delete (D) source Data ? '
180 write(*,*)' Enter M, A, D, or Hit RETURN to continue: '
read(*, ' (al) •) cl
if( cl .eg. 'M1 .or. cl .eg. 'm1 ) go to 200
if( cl .eg. 'D1 .or. cl .eg. 'd' ) go to 300
if( cl .eg. 'A1 .or. cl .eg. 'a' ) go to 400
if( cl .eg. ' ' ) go to 500
200 write (*,*)' Enter source number you wish to change: '
read (*, 1005) clO
ierr - atoi(clO, ns)
if(ierr .eg. -1) ns - -1
if(ns .gt. 0 .and. ns .le. nstack) then
write(*,*) ' Hit RETURN to persist value.1
write(*,*) ' Stack Ht ', source (4, ns) ,' [m] ',
& ' new value ? '
STK00010
• STK00020
STK00030
STK00040
STK00050
STK00060
STK00070
STK00080
STK00090
STK00100
STK00110
STK00120
STK00130
STK00140
STK00150
STK00160
STK00170
STK00180
STK00190
STK00210
STK00220
STK00230
STK00240
STK00250
STK00260
STK00270
STK00280
STK00290
STK00300
STK00310
STK00320
STK00330
STK00340
STK00350
STK00360
STK00370
STK003&Q-
STK00390
STK00400
STK00410
STK00420
STK00430
STK00440
STK00450
STK00460
STK00470
STK00480
STK00490
STK00500
STK00510
STK00520
STK00530
STK00540
STK00550
STK00560
STK00570
STK00580
STK00590
STK00600
STK00610
STK00620
STK00630
STK00640
STK00650
STK00660
226
-------
210
220
230
240
250
C
300
304
306.
310
320
else
read(*,!005) clO
ierr » atof( clO, x )
if( ierr .eq. -1 ) go to 210
source(4,ns) = x
write(*,*) ' Stack Dia ',source(5,ns),' [m] ',
1 new value ? '
read(*,1005) clO
ierr * atof( clO, x )
if( ierr .eq. -1 ) go to 220
source(5,ns) = x
write(*,*) ' Stack Temp ',source(6,ns),' [deg-K] ',
1 new value ? '
read(*,1005) clO
ierr * atof( clO, x )
if( ierr .eq. -1 ) go to 230
source(6,ns) » x
write(*,*) ' Stack Exit Velocity ',source(7,ns),
1 [m/s] new value ? '
read(*,1005) clO
ierr - atof( clO, x )
if( ierr .eq. -1 ) go to 240
source(7,ns) = x
write(*,*) ' Emission Rate ',source(8,ns),
1 [<3/s] new value ? '
read(*,1005) clO
ierr =• atof( clO, x )
if( ierr .eq. -1 ) go to 250
source(8,ns) * x
call zapchrQ
write(*,6030)
write(*,6040) ns, (sname(i,ns),i=l,4), source(8,ns),
chr7x(ns), chr7y(ns), (source(j,ns),j=4,7)
write(*,*) ' Modify other sources ? '
go to 160
write(*,*) ' Invalid source number! Try Again.1
endif
go to 160
delete source
write(*,*) • Enter source number to be deleted or RETURN',
1 to continue: '
read(*,1005) clO
ierr - atoi(clO,ndel)
iff ierr .eq. -1 ) go to 160
if( ndel .gt. 0 .and. ndel .le. nstack) then
writ«(*,6040) ndel,(sname(i,ndel),i«l,4),source(8,ndel)
chr7x(ndel),chr7y(ndel),(source(j,ndel),j-4,7)
write(*,*)
writa(*,*)' Delete this source ? [Y/N]:'
read(*,'(al)') cl
if(cl .eq. 'N' .or. cl .eq. 'n') go to 160
if(cl .eq. 'Y' .or. cl .eq. 'y') go to 306
go to 304
do 340 ns-ndel,nstack-l
do 310 i*l,4
sname(i,ns) > sname(i,ns+l)
continue '
do 320 i-4,8
source(i,ns) - source(i,ns-H)
continue
chr7x(ns) - chr7x(ns+l)
chr7y(ns) - chr7y(ns+l)
chr7z(ns) - chr7z(ns+l)
STK00670
STK00680
STK00690
STK00700
STK00710
STK00720
STK00730
STK00740
STK00750
STK00760
STK00770
STK00780
STK00790
STK00800
STK00810
STK00820
STK00830
STK00840
STK00850
STK00860
STK00870
STK00880
STK00890
STK00900
STK00910
STK00920
STK00930
STK00940
STK00950
STK00960
STK00970
STK00980
STK00990
STK01000
STK01010
STK01020
STK01030
STK01040
STK0105&-
STK01060
STK01070
STK01080
STK01090
STK01100
STK01110
STK01120
STK01130
STK01140
,STK01150
STK01160
STK01170
STK01180
STK01190
STK01200
STK01210
STK01220
STK01230
STK01240
STK01250
STK01260
STK01270
STK01280
STK01290
STK01300
STK01310
STK01320
ft,
227
-------
340
400
500
510
ivar(ns) = ivar(ns-t-l)
continue
nstack » nstack - l
else
write(*,*) ' Invalid source Number! Try Again.'
go to 300
endif
go to 160
add new source
nstack »• nstack + 1
if(nstack .gt. MAXSOR) then
write(*,*) ' MAXIMUM NUMBER OF sources EXCEEDED '
nstack » nstack - l
go to 160
endif
ns = nstack
call zapchr()
write (*,*)' Create New source1
write(*,*) ' '
write (* *) * Source Name: '
read ( * ,
write ( *
readf*,
call put
write(*
read(*,
call pu1
write (*
read ( * ,
call put
write (*
read(»,
write (*
read ( * ,
write (*
read ( * ,
write ( *
*»««&«4 / *
(4a4)') (sname(i,ns) , i-l,<
*) ' X-Coord (max 7 digits
(a7) ') chr7x(ns)
:dot(chr7x(ns) ,7)
*) ' Y-Coord (max 7 digits
(a7) ') chr7y(ns)
:dot(chr7y(ns) ,7)
*) ' Z-Coord (max 7 digits
(a7) ') chr7z(ns)
:dot(chr7z(ns) ,7)
*) ' Stack Height [m] : '
(f7.0)') source(4,ns)
*) ' Stack Diameter [m] : '
(f7.0) ') source (5, ns)
*) ' Stack Gas Temperature
(f7.0) ') source ( 6, ns)
l)
including decimal point) : '
including decimal point) : '
,
including decimal point) : '
[deg-K] : '
*) ' Stack Gas Exit Velocity [m/s]:'
write(*,*)'
read(*, ' (f7.0)
ivar(ns) - NO
go to 130
Emission Rate [g/s]:1
source(8,ns)
do 510 ns-1, nstack
writ«(2,2000) (sname(i,ns) , i-1, 4) ,
& chr7x(ns) ,chr7y(ns) ,chr7z(ns) ,
& (source(;j ,ns) , j-4,8) , ivar(ns)
continue
write (2, 2 010)
call zapchrQ
write (6, 6030)
do 520 ns-1, nstack
write(*,6040) ns, (sname(i,ns) , i-1,4) ,source(8,ns) ,
& chr7x(ns), chr7y(ns), (source( j ,ns) , j=4 ,7)
520 continue
call delay
return
1005 format (a 10)
1030 format(4a4,3a7,5f7.0,7x,il)
2000 format (4a4 , 3a7 , f 7 . 2 , f 7 . 3 , f 7 . 1 , f 7 . 3 , f 7 . 2 , i8 )
STK01330
STK01340
STK01350
STK01360
STK01370
STK013SO
STK01390
STK01400
STK01410
STK01420
STK01430
STK01440
STK01450
STK01460
STK01470
STK01480
STK01490
STK01500
STK01510
STK01520
STK01530
STK01540
STK01550
STK01560
STK01570
STK01580
STK01590
STK01600
STK01610
STK01620
STK01630
STK01640
STK01650
STK01660
STK01670
STK01680
STK01690
STK0170tT
STK01710
STK01720
STK01730
STK01740
STK01750
STK01760
STK01770
STK01780
STK01790
STK01800
STK01810
STK01820
STK01830
STK01840
STK01850
STKOL860
STK01870
STK01880
STK01890
STK01900
STK01910
STK01920
STK01930
STK01940
STK01950
STK01960
STK01970
STK01980
228
-------
2010
6030
1
2
3
4
5
6
7
format('ENDS')
FORMAT(
1 ',T17,'***SOURCE INFORMATION***1,//,
T22,'EMISSION LOCATION STK STK GAS EXIT'/,
1 STK NAME RATE (USER UNITS) ',
1 HT DIA TEMP VEL ',/, ' f',
T22,1 (G/S) X Y (M) (M) (K) (M/S)'/,
6040
format(13,Ix,4a4,f9.2,Ix,a7,Ix,a?,ix,f6.1,Ix,f6.2,f6.1,f6.2)
end
STK01990
STK02000
STK02010
STK02020
STK02030
STK02040
STK02050
STK02060
STK02070
STK02080
STK02090
STK02100
229
-------
subroutine swname(fi, f2) SWNOOOIO
character*(*) fl, f2 swS§§§2§
SWN00030
write(3,3010) fl SWN00040
write(3,3020) f2, fl SWN00050
write(3,3030) f2 SWN00060
SWN00070
3010 format(' Rename ',a ,' wxyzzyxw1) SWN00080
3020 fonnat('_Rename ',a ,' ',a ) SWN00090
3030 format('TRename wxyzzyxw ',a,/,' ') SWN00100
SWN00110
return SWN00120
end SWN00130
230
-------
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
c-
subroutine zapchr( )
Subroutine: 2APCHR
Purpose: Clear the screen.
Assumptions/Limitations:
Some compilers have a subroutine which allows execution of DOS
commands during program execution. The Lahey FORTRAN compiler
which performs this function is CALL SYSTEM("dos command").
If your compiler allows this then comment out the marked
statements below.
I/O: None or 24 blank lines to the console.
Called By: Everyone (almost)
Calls: None
Include Files: None
Version: 1.0 Level: 871109
system command to clear screen
CALL SYSTEM('CLS')
-brute force method to clear screen
write(*,1)
format(30(/))
return
end
ZAP00010
ZAP00020
ZAP00030
ZAP00040
ZAP00050
ZAP00060
ZAP00070
ZAP00080
ZAP00090
ZAP00100
ZAP00110
ZAP00120
ZAP00130
ZAP00140
ZAP00150
ZAP00160
ZAP00170
ZAP00180
ZAP00190
ZAP00200
ZAP00210
ZAP00220
-ZAP00230
ZAP00240
ZAP00250
ZAP00260
ZAP00270
ZAP00280
ZAP00290
ZAP00300
ZAP00310
ZAP00320
ZAP00330
ZAP00340
231
-------
INTERACT INCLUDE Files
232
-------
c-
c
c
c
c
c
c
c
c
c
c
c-
PARAMETER(
PARAMETER(
PARAMETER(
PARAMETER(
PARAMETER(
PARAMETER(
PARAMETER(
MAXLIN
MAXHIL
MAX2
MAXSOR
MXDPTS
MAXREC
MAXLEV
57)
35)
21)
20)
25)
400)
50)
MAXLIN MAXIMUM NUMBER OF PRINTED LINES PER PAGE (COMMON.HEAD)
MAXHIL MAXIMUM NUMBER OF HILLS (COMMON.HILL)
MAXZ MAX NUMBER OF HILL HEIGHT CONTOURS (COMMON.HILL)
MAXSOR MAXIMUM NUMBER OF SOURCES (COMMON.STACKS)
MXDPTS MAX NUMBER OF DOWNWIND GRID POINTS (COMMON.PASL)
MAXREC MAX NUMBER OF RECEPTORS (COMMON.RECEPT)
MAXLEV MAX NUMBER OF MET DATA LEVELS (COMMON.PROFIL)
233
-------
c
c
INTEGER HILNAM(10,MAXHIL)
REAL MAJORW, MAJAXW, MINAXW, MAJORL
COMMON/ HILL/ NHILLS, HILNAM, NZH(MAXHIL), ZHS(MAXZ,MAXHIL)
*
*
it
*
*
*
*
*
C
C DEFINITIONS
THS(MAXHIL), ZOH(MAXHIL),
XHW (MAXZ , MAXHIL) , YHW (MAXZ , MAXHIL) ,
MAJORW (MAXZ, MAXHIL) ,
MAJAXW (MAXZ , MAXHIL) , MINAXW (MAXZ , MAXHIL) ,
XHL (MAXZ, MAXHIL) , YHL (MAXZ , MAXHIL) ,
MAJORL (MAXZ, MAXHIL) ,
EXPOMA (MAXZ , MAXHIL) , EXPOMI (MAXZ , MAXHIL) ,
SCALMA (MAXZ , MAXHIL) , SCALMI (MAXZ , MAXHIL)
C GENERAL VARIABLES:
C NHILLS
C HILNAM
C NZH
C
C ZHS
C
C THS
C ZOH
C
C VARIABLES
C
C XHW
C
C YHW
C
C MAJORW
C
C MAJAXW
C
C MINAXW
C
C
C VARIABLES
C
C XHL
C
C YHL
C
C MAJORL
C
C EXPOMA
C
C EXPOMI
C
C SCALMA
C
C SCALMI
C
NUMBER OF HILLS (MAX=*MAXHIL)
NAME OF HILL (40 CHARACTER MAX)
NUMBER OF HEIGHTS FOR WHICH ELLIPSE AND CUTOFF HILL
SHAPE VARIABLES ARE PROVIDED, SPECIFIED FOR EACH HILL
HEIGHTS FOR WHICH ELLIPSE AND CUTOFF HILL SHAPE
VARIABLES ARE PROVIDED, METERS ABOVE STACK BASE
HEIGHT OF TOP OF HILL ABOVE STACK BASE, METERS
SURFACE ROUGHNESS LENGTH OF HILL
FOR WRAP:
X-COORDINATE OF CENTER OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
Y-COORDINATE OF CENTER OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
ORIENTATION OF MAJOR AXIS OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, DEGREES CLOCKWISE FROM NORTH
LENGTH OF MAJOR SEMI-AXIS OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
LENGTH OF MINOR SEMI-AXIS OF ELLIPTICAL CONTOUR FOR A
SPECIFIC VALUE OF ZH, METERS
FOR LIFT:
X-COORDINATE OF CENTER OF THE CUTOFF HILL FOR A
SPECIFIC VALUE OF ZH, METERS
Y-COORDINATE OF CENTER OF THE CUTOFF HILL FOR A
SPECIFIC VALUE OF ZH, METERS
ORIENTATION OF MAJOR AXIS OF THE CUTOFF HILL FOR A
SPECIFIC VALUE OF ZH, DEGREES CLOCKWISE FROM NORTH
EXPONENT IN INVERSE POLYNOMIAL REPRESENTATION OF
CUTOFF HILL SHAPE FUNCTION FOR MAJOR AXIS CROSS SECTION
EXPONENT IN INVERSE POLYNOMIAL REPRESENTATION OF
CUTOFF HILL SHAPE FUNCTION FOR MINOR AXIS CROSS SECTION
SCALE LENGTH (M) IN INVERSE POLYNOMIAL EQUATION FOR
CUTOFF HILL SHAPE FUNCTION FOR MAJOR AXIS CROSS SECTION
SCALE LENGTH (M) IN INVERSE POLYNOMIAL EQUATION FOR
CUTOFF HILL SHAPE FUNCTION FOR MINOR AXIS CROSS SECTION
234
-------
c-
c
REAL
COMMON/PROFIL/
WDHR(MAXLEV),
SVHR(MAXLEV),
HT(MAXLEV)
WDHR, WSHR,
HT, NHT
WSHR(MAXLEV),
SWHR(MAXLEV),
UVHR(MAXLEV),
TAHR(MAXLEV),
UVHR, SVHR, SWHR, TAHR,
c
C VARIABLES:
C
C
C
C
C
C
C
C
C
C
C
C
C
WDHR
WSHR
UVHR
SVHR
SWHR
TAHR
HT
NHT
REAL
REAL
REAL
REAL
REAL
REAL
REAL
INT
ARRAY OF WIND DIRECTIONS (DEC) AT MULTIPLE
HEIGHTS
ARRAY OF SCALAR WIND SPEEDS (M/S) AT MULT. HTS
ARRAY OF VECTOR WIND SPEEDS (M/S) AT MULT. HTS
ARRAY OF SIGMA-V'S (DEC) AT MULTIPLE HEIGHTS
ARRAY OF SIGMA-W'S (M/S) AT MULTIPLE HEIGHTS
ARRAY OF AMBIENT TEMPERATURES (DEG K) AT
MULTIPLE HEIGHTS
ARRAY OF HEIGHTS (M) FOR ABOVE PARAMETERS.
NEGATIVE HEIGHTS INDICATE NO MORE DATA
NUMBER OF LEVELS OF DATA
235
-------
c-
c
c
c
c
c
c
c
c
c
c
c
c
c
c-
REAL
INTEGER
COMMON/
DEFINITIONS:
NRECPT
RNAME
RECPT
KRECPT
NRHILL
RECPT(4,MAXREC)
NRECPT, RNAME(4,MAXREC), NRHILL(MAXREC)
RECEPT/ NRECPT, RNAME, RECPT, KRECPT, NRHILL
INT NUMBER OF RECEPTORS
INT ARRAY OF RECEPTOR NAMES (16 CHARACTERS EACH)
REAL ARRAY OF RECEPTOR INFORMATION
RECPT(1,N) X COORDINATE (M)
RECPT(2,N) Y COORDINATE (M)
RECPT(3,N) HEIGHT ABOVE GROUND (M)
RECPT(4,N) GROUND ELEVATION (M)
INT NUMBER OF HOURS RECEPTOR LOCATIONS ARE VALID
INT HILL NUMBER THIS RECEPTOR IS ON
236
-------
c
c
REAL
INTEGER
COMMON/
C
C DEFINITIONS:
SOURCE(11,MAXSOR)
SNAME(4,MAXSOR), IVAR(MAXSOR)
STACKS/ NSTACK, SNAME, SOURCE, KEMIS, IVAR
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
c
c
c
c-
NSTACK
SNAME
SOURCE
INT
INT
REAL
NUMBER OF SOURCES THIS RUN
ARRAY OF SOURCE NAMES
ARRAY OF SOURCE PARAMETERS
-N)
KEMIS
IVAR
INT
INT
SOURCE(1,
SOURCE(2,N)
SOURCE(3,N)
SOURCE(4,N)
SOURCE(5,N)
SOURCE(6,N)
SOURCE(7,N)
SOURCE(8,N)
SOURCE(9,N)
SOURCE(10,N)
SOURCE(11,N)
X-COORDINATE (M)
Y-COORDINATE (M)
Z-COORDINATE (M)
STACK HEIGHT (M)
STACK DIAMETER (M)
STACK GAS TEMPERATURE (DEG-K)
STACK GAS EXIT VELOCITY (M/S)
EMISSION RATE (G/S)
ASSOCIATED BUILDING HEIGHT (M)
USED FOR DOWNWASH CONDITIONS
BUOY. FLUX PORTION: G*VS*DS*DS/4
MOM. FLUX PORTION: VS*VS*DS*DS/4
NUMBER OF SOURCES WITH HOURLY EMISSIONS
ARRAY OF FLAGS FOR SOURCES WITH HOURLY EMISSIONS
237
-------
APPENDIX F
GRAPHICAL CONCENTRATION DISPLAY CODE LISTINGS
238
-------
CHIRET Concentration Retrieval Program
239
-------
PROGRAM CHIRET
C***PROGRAM TO RETRIEVE CTDM CALCULATED CONCENTRATIONS BY RECEPTOR FOR
C***A SPECIFIC RANGE OF HOURS SPECIFIED BY THE USER. FOR A GIVEN HILL,
C***THE NUMBER AND LOCATION OF RECEPTORS IS ASSUMED TO BE CONSTANT FOR
C***THE RANGE OF HOURS SPECIFIED. FOR EACH HOUR, THE CONCENTRATIONS ARE
C***SORTED FROM THE HIGHEST TO THE LOWEST OVER THE FIELD OF RECEPTORS.
C***THESE SORTED CONCENTRATIONS ARE THEN OUTPUT TO A FILE FOR INPUT TO
C***THE PROGRAM CHIDIS FOR DISPLAY OF THE CONCENTRATIONS ON A MAP OF
C***UNEDITED CONTOURS.
C***
C***
C GLOSSARY OF TERMS
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
CHIFL=NAME OF THE CTDM OUTPUT FILE CONTAINING THE CALCULATED
CONCENTRATIONS
CHISRT=NAME OF THE OUTPUT FILE CONTAINING THE HOURLY CONCENTRATIONS
AND RECEPTOR COORDINATES SORTED BY CONCENTRATION
CHOUR-SUBROUTINE CALLED TO CALCULATE THE ELAPSED NUMBER OF HOURS
FROM 00/01/01:00 TO THE YY/MM/DD:HH IN QUESTION
CONC(I)=CONCENTRATION FOR RECEPTOR I FOR A PARTICULAR HOUR
DAY=TWO DIGIT INTEGER SPECIFYING THE DAY(01-31)
DCODET=SUBROUTINE USED TO DETERMINE THE YEAR,MONTH,DAY AND HOUR
FROM THE INTEGER ARRAY ITIME
HOUR=»TWO DIGIT INTEGER SPECIFYING THE HOUR(01-24)
ID=HILL IDENTIFICATION NUMBER FOR A PARTICULAR RECEPTOR IN THE
RECEPTOR FILE
IDHILL=HILL IDENTIFICATION NUMBER INPUT BY THE USER
IEND-END OF DATA FLAG FOR THE PLOT FILE USED BY THE CONCENTRATION
PLOTTING PROGRAM
=0(MORE PLOT FILE DATA TO FOLLOW)
=1(NO MORE PLOT FILE DATA TO FOLLOW)
IEF=COMPLETION CODE RETURNED BY SUBROUTINE READIT
=0(END OF CTDM CONCENTRATION OUTPUT FILE NOT REACHED)
-1(END OF CTDM CONCENTRATION OUTPUT FILE REACHED)
IFLAG-COMPLETION FLAG FOR SUBROUTINE CHOUR
-0(DAY-MONTH ASSIGNMENT WITHIN RANGE)
-1(DAY-MONTH ASSIGNMENT OUT OF RANGE)
IFMT-FORMAT INDICATOR FOR THE CTDM CONCENTRATION OUTPUT FILE
=1(FORMATTED)
-2(UNFORMATTED)
CHI00010
CHIQ0020
CHI30030
CHI00040
CHIQ0050
CHI00060
CHI00070
CHI00080
CHI00090
CHI00100
CHI00110
CHI00120
CHI00130
CHI00140
CHI00150
CHI00160
CHI00170
CHI00180
CHI00190
CHI00200
CHI00210
CHIQ0220
CHI00230
CHI00240
CHI00250
CHI00260
CHI00270
CHI00280
CHI00290
CHI00300
CHI00310
CHI00320
CHI00330
CHI00343-
CHI00350
CHI00360
CHI00370
CHI00380
CHI00390
CHI00400
CHI00410
IHRT-HOUR FOR A PARTICULAR RECORD FROM THE CTDM CONCENTRATION OUTPUTCHI00420
FILE(WITH RESPECT TO 00/01/01:01) CHI00430
IHRTS-STARTING HOUR(WITH RESPECT TO 00/01/01:01) FOR SELECTION OF CHI00440
CONCENTRATION RECORDS FROM THE CTDM OUTPUT FILE CHI.00450
IHRTF-ENDING HOUR(WITH RESPECT TO 00/01/01:01) FOR SELECTION OF CHI 00460
CONCENTRATION RECORDS FROM THE CTDM OUTPUT FILE CHI00470
INCHI-UNIT NUMBER FOR THE CTDM CONCENTRATION OUTPUT FILE CHI00480
INREC=UNIT NUMBER FOR THE CTDM INPUT RECEPTOR FILE CONTAINING RECEPTCHI00490
COORDINATES CHI00500
ISEI>S£LECTION MODE FOR RECORDS FROM THE CTDM CONCENTRATION OUTPUT CHI00510
FILE CHI00520
-1(ONLY THE FIRST RECORD FROM THE FILE IS SELECTED) CHI00530
-2(ALL RECORDS FOR THE FILE ARE SELECTED) CHI00540
-3(ALL RECORDS SELECTED BETWEEN A USER SPECIFIED STARTING AND CHI00550
ENDING TIME) CHI00560
ITIME-ARRAY CONTAINING THE YEAR,MONTH,DAY,JULIAN DAY,HOUR, AND CHI00570
NUMBER OF RECEPTORS(IN PACKED FORM) FOR A GIVEN RECORD IN THE CHI00580
CTDM CONCENTRATION OUTPUT FILE CHI00590
IUSE(I)-FLAG INDICATING WHETHER RECEPTOR I BELONGS TO THE HILL IN CHI00600
240
-------
QUESTION CHI00610
=0(RECEPTOR NOT ON HILL) CHI00620
-1(RECEPTOR IS ON THE HILL) CHIQQ63Q
IZERO=INTEGER VALUE OF ZERO CHI00640
LPTR=ARRAY REQUIRED BY THE POINTER SORT SUBROUTINE PSORTR CHI00650
MONTH=TWO DIGIT INTEGER SPECIFYING THE MONTH(01-12) CHI00660
NPTR(I)=«RECEPTOR I RANK IN ASCENDING ORDER OF CONCENTRATION CHI00670
NR=NUMBER OF RECEPTORS IN THE CTDM INPUT RECEPTOR FILE BELONGING CHI00680
TO HILL IDHILL CHI00690
NRMAX=MAXIMUM NUMBER OF RECEPTORS ALLOWED(CURRENTLY SET AT 1000) CHI00700
NRT-TOTAL NUMBER OF RECEPTORS IN THE CTDM RECEPTOR FILE CHI00710
OUTCHI=UNIT NUMBER OF THE FILE OF SORTED CONCENTRATIONS TO BE PLOTTECHI00720
READIT=SUBROUTINE USED TO READ THE RECORDS FROM THE CTDM OUTPUT FILECHI00730
RECFIL-NAME OF THE CTDM INPUT RECEPTOR FILE CONTAINING RECEPTOR CHI00740
COORDINATES CHI00750
XMIN,XMAX,YMIN,YMAX-BOUNDARIES OF THE RECTANGLE ENCLOSING THE RECEPTCHI00760
C
C
C
<•»
C
C
C
C
C
C
C
C
C
C
C
C
C POINTS ON HILL IDHILL CHI00770
C XREC(I)-X-COORDINATE FOR RECEPTOR I CHI00780
C YEAR-TWO DIGIT INTEGER SPECIFYING THE YEAR(00-99) CHI00790
C YREC(I)-Y-COORDINATE FOR RECEPTOR I CHI00800
C*** CHI00810
C*** CHI00820
CHARACTER*14 CHIFL,RECFIL,CHISRT CHI00830
INTEGER OUTCHI,YEAR,DAY,HOUR CHI00840
DIMENSION XREC(IOOO),YREC(1000),NPTR(1000),LPTR(1000),IUSE(1000), CHI00850
&ITIME(4),CONC(1000) CHI00860
C***SET THE ELEMENTS OF THE IUSE ARRAY TO ZERO. CHI00870
DATA IUSE/1000*0/ CHI00880
C***SET THE MAXIMUM NUMBER OF ALLOWABLE RECEPTORS CHI00890
NRMAX-1000 CHI00900
C***SET END OF DATA FLAG FOR PLOT FILE INITIALLY TO ZERO. CHI00910
IEND-0 CHI00920
C***SET ZERO INTEGER CHI00930
IZERO-0 CHI00940
C***SPECIFY FILE UNIT NUMBERS CHI00950~
INCHI-14 CHI00960
OUTCHI-15 CHI00970
INREC-16 CHI00980
C*** CHI00990
C*** CHI01000
C SPECIFY INPUT FILE NAMES AND OPEN FILES. CHI01010
C*** ' ' CHI01020
C*** CHI01030
C***ENTER THE NAME OF THE CONCENTRATION OUTPUT FILE FROM CTDM. CHI01040
5 WRITE(*,10) CHI01050
10 FORMAT(/,IX,'ENTER NAME OF CONCENTRATION FILE(FROM CTDM) -> ') CHI01060
READ(*,'(A)') CHIFL CHI01070
IFfCHIFL.EQ.' ') GO TO 5 CHI01080
C***DETERMINE WHETHER THIS FILE IS FORMATTED OR UNFORMATTED. CHI01090
15 WRITE(*,20) CHI01100
20 FORMAT(//,23X,'SPECIFY CONCENTRATION FILE FORMAT1,/, CHI01110
S23X,'l.) FORMATTED',/, CHI01120
&23X,'2.) UNFORMATTED',/, CHI01130
&27X,'CHOICE?(1 OR 2) -> ') CHI01140
READ(*,*,ERR-15) IFMT CHI01150
If(IFMT.LT.1.0R.IFMT.GT.2) GO TO 15 CHI01160
IF(IFMT.EQ.2) GO TO 100 CHI01170
C***OPEN A FORMATTED CONCENTRATION FILE. CHI01180
OPEN(INCHI,ERR-30,FILE-CHIFL,STATUS-1OLD',FORM='FORMATTED', CHI01190
&ACCESS-1SEQUENTIAL1) CHI01200
241
-------
NOT EXIST',/,
BY THE USER1,
GO TO 200
30 WRITE(*,40) CHIFL
40 FORMAT(//,1X,'***ERROR***FILE ',A14,' DOES
SIX,'OR DOES NOT MATCH THE FORMAT SPECIFIED
SIX,'SPECIFY FILE NAME AGAIN1,/)
GO TO 5
C***OPEN AN UNFORMATTED CONCENTRATION FILE.
100 OPEN(INCHI,FILE=CHIFL,STATUS='OLD',FORM='UNFORMATTED1,
&ERR-30,ACCESS-'SEQUENTIAL')
200 CONTINUE
C***INPUT THE HILL IDENTIFICATION NUMBER.
205 WRITE(*,210}
210 FORMAT(/,IX,'ENTER THE HILL IDENTIFICATION NUMBER(l-99) -> ')
READ(*,*,ERR=205) TDHILL
IF(IDHILL.LT.1.0R.IDHILL.GT.99) GO TO 205
C***ENTER THE NAME OF THE CTDM INPUT RECEPTOR FILE(CONTAINING RECEPTOR
C***COORDINATES) CORRESPONDING TO THE CONCENTRATION OUTPUT FILE JUST
C***OPENED.
215 WRITE{*,220)
220 FORMAT(/,IX,'ENTER NAME OF THE CTDM INPUT RECEPTOR FILE -> ')
READ(*,'(A)') RECFIL
IF{RECFIL.EQ.' ') GO TO 215
C***OPEN THE RECEPTOR FILE.
OPEN(INREC,FILE=RECFIL,STATUS='OLD',ERR=230)
GO TO 240
230 WRITE(*,40) RECFIL
GO TO 215
C***SET THE COUNTER OF TOTAL RECEPTORS TO ZERO.
240 NRT-0
C***SET THE COUNTER OF SELECTED HILL RECEPTORS TO 0(THE FILE RECFIL MAY
C***HAVE RECEPTORS FOR HILLS OTHER THAN THE HILL SELECTED).
NR-0
C***INITIALI2E VALUES FOR XMIN,XMAX,YMIN, AND YMAX. THESE PARAMETERS
C***WILL EVENTUALLY BE USED TO DETERMINE THE BOUNDARIES OF THE
C***CONCENTRATION PLOT.
XMIN-l.OE+15
XMAX—l.OE+15
YMIN-l.OE+15
YMAX—l.OE-t-15
C***
C***
C READ IN RECEPTOR INFORMATION.
C***
C***
250 CONTINUE
NRT-NRT+1
IF(NRT.GT.NRMAX) GO TO 270
READ(INREC,260,END-290) XREC(NRT),YREC(NRT),ID
260 FORMAT(20X,2F10.0,20X,I5)
C***DETERMINE WHETHER THE HILL IDENTIFICATION NUMBER FOR THE RECEPTOR
C***MATCHES THE HILL IDENTIFICATION NUMBER INPUT BY THE USER.
IF(ID.NE.IDHILL) GO TO 250
NR-NR+1
IUSE(NRT)-1
C***UPDATE PLOT BOUNDARIES FOR THE RECEPTOR FIELD.
IF(XREC(NRT).LT.XMIN) XMIN-XREC(NRT)
IF(XREC(NRT).GT.XMAX) XMAX-XREC(NRT)
IF(YREC(NRT).LT.YMIN) YMIN-YREC(NRT)
IF(YREC(NRT).GT.YMAX) YMAX-YREC(NRT)
GO TO 250
CHI01210
CHI01220
CHI01230
CHI01240
CH101250
CHTQ1260
CHI01270
CHI01280
CHI01290
CHI01300
CHI01310
CHI01320
CHI01330
CHI01340
CHI01350
CHI01360
CHI01370
CH101380
CHI01390
CHI01400
CH101410
CH101420
CHI01430
CHi:01440
CHI01450
CH:C01460
CHI01470
CHI01480
CHI01490
CHI01500
CHI01510
CHI01520
CHI01530
CH.T01540
CHI01558-
CH.I01560
CHI01570
CHI01530
CHI01590
CHI01600
CHI01610
CHI01620
CHI01630
CHI01640
CHI01650
CHI01660
CHI01670
CHI01680
CHI01690
CHI01700
CHI01710
CHI01720
CHI01730
CHI01740
CHI01750
CHI01760
CHI01770
CHI01780
CHI01790
CHI01800
242
-------
270 WRITE(*,280) NRMAX CHI01310
280 FORMAT(/,IX,'***WARNING***ONLY THE FIRST',15,IX,'RECEPTORS WILL BECHI01820
4 ANALYZED1) CHI01830
290 IF(NR.EQ.O) GO TO 1000 CHI01340
NRT=NRT-1 CHI01350
WRITE(*,300) NR,NRT,IDHILL GHI01860
300 FORMAT(/,1X,I4,1X,'OUT OF',14,IX,'RECEPTORS WERE FOUND TO BE ON HICHI01870
&LL',I4) CHI01880
C***CLOSE THE RECEPTOR FILE. CHI01890
CLOSE(INREC) CHI01900
C*** CHI01910
C*** CHI01920
C***SPECIFY THE SELECTION MODE FOR CONCENTRATION RECORDS. CHI01930
C*** CHI01940
C*** CHI01950
C***THREE MODES ARE AVAILABLE FOR THE SELECTION OF CONCENTRATION CHI01960
C***RECORDS FOR PLOTTING. CHI01970
C***MODE 1-ONLY THE FIRST RECORD IN THE CONCENTRATION FILE IS USED. CHI01980
C***MODE 2-ALL CONCENTRATION FILE RECORDS ARE USED. CHI01990
O**MODE 3-ALL RECORDS USED BETWEEN STARTING AND ENDING TIMES SPECIFIED CHI02000
C*** BY THE USER. CHI02010
330 WRITE(*,340) CHI02020
340 FORMAT(//,18X,'SPECIFY CONCENTRATION RECORD SELECTION MODE',/, CHI02030
&22X,'l.) ONLY THE FIRST RECORD IS SELECTED1,/, CHI02040
&22X,'2.) ALL RECORDS SELECTED1,/, CHI02050
&22X,'3.) ALL RECORDS SELECTED BETWEEN A START AND END TIME',/, CHI02060
&26X,'CHOICE?(1,2 OR 3) -> ') CHI02070
READ(*,*,ERR=330) ISEL CHI02080
IF(ISEL.LT.1.OR.ISEL.GT.3) GO TO 330 CHI02090
IF(ISEL.NE.3) GO TO 500 CHI02100
C***INPUT THE START TIME(YEAR,MONTH,DAY,HOUR) FOR SELECTION OF CHI02110
C* "CONCENTRATIONS. CHI 02120
400 WRIT£(*,410) CHI02130
410 FORMAT(/,22X,'INPUT START TIME(YEAR,MONTH,DAY,HOUR)',/, CHI02140
&22X,'EXACTLY AS SHOWN(YY/MM/DD:HH) -> ') CHI0215TT
READ(*,420) YEAR,MONTH,DAY,HOUR CHI02160
420 FORMAT(3(12,IX),12) CHI02170
IF(YEAR.LT.O) GO TO 400 CHI02180
IF(MONTH.LT.1.0R.MONTH.GT.12) GO TO 400 CHI02190
IF(DAY.LT.1.OR.DAY.GT.31) GO TO 400 CHI02200
IF(HOUR.LT.1.OR.HOUR.GT.24) GO TO 400 CHI02210
C***CALCULATE THE STARTING HOUR WITH RESPECT TO 00/01/01:00 CHI02220
CALL CHOUR(YEAR,MONTH,DAY,HOUR,IHRTS,IFLAG) CHI02230
IF(IFLAG.EQ.O) GO TO 430 CHI02240
WRITE(*,425) CHI02250
425 FORMAT (/, IX, 'DAY OF THE MONTH OUT OF RANGE—TRY AGAIN') CHI02260
GO TO 400 CHI02270
C***INPUT THE END TIME(YEAR,MONTH,DAY,HOUR) FOR SELECTION OF CHI02280
C* "CONCENTRATIONS. CHI02290
430 WRITE(*,440) CHI02300
440 FORMAT(/,22X,'INPUT END TIME(YEAR,MONTH,DAY,HOUR)',/, CHI02310
&22X,'EXACTLY AS SHOWN(YY/MM/DD:HH) ->') CHI02320
READ(*,420) YEAR,MONTH,DAY,HOUR CHI02330
IF(YEAR.LT.O) GO TO 430 CHI02340
IF(MONTH.LT.1.0R.MONTH.GT.12) GO TO 430 CHI02350
IF(DAY.LT.1.OR.DAY.GT.31) GO TO 430 CHI02360
IF(HOUR.LT.1.OR.HOUR.GT.24) GO TO 430 CHI02370
C***CALCULATE THE ENDING HOUR WITH RESPECT TO 00/01/01:00 CHI02380
CALL CHOUR(YEAR,MONTH,DAY,HOUR,IHRTF,IFLAG) CHI02390
IF(IFLAG.EQ.O) GO TO 455 CHI02400
243
-------
WRITE(*,450)
450 FORMAT(/,IX,
GO TO 430
455 IF(IHRTF.GE.IHRTS)
WRITE(*,460)
460 FORMAT(/,IX,
GO TO 400
CONTINUE
DAY OF THE MONTH OUT OF RANGE—TRY AGAIN')
GO TO 500
STARTING TIME GREATER THAN ENDING TIME—TRY AGAIN
1-HOUR CONCENTRATIONS AND WRITE THEM
•'UNKNOWN')
OF RECEPTORS
TO THE PLOT FILE.
500
C***
C***
C READ AND SORT(BY RECEPTOR)
C TO A FILE FOR PLOTTING.
C***
C***
C***INPUT THE NAME OF THE PLOT FILE FOR CONCENTRATIONS AND RECEPTOR
C***COORDINATES.
510 WRITE(*,520)
520 FORMAT(/,IX,'ENTER OUTPUT FILE NAME - > ')
READ(*,'(A)') CHISRT
IF(CHISRT.EQ.' ') GO TO 510
C***OPEN THE PLOT FILE.
OPEN(OUTCHI,FILE-CHISRT,STATUS'
C***WRITE THE HILL NUMBER AND NUMBER
WRITE(OUTCHI,530) IDHILL,NR
530 FORMAT(2I5)
C***WRITE THE BOUNDARIES OF THE RECEPTOR FIELD TO THE PLOT FILE.
WRITE(OUTCHI,540) XMIN,XMAX,YMIN,YMAX
540 FORMAT(4E15.4)
C***READ A SET OF CONCENTRATIONS FROM THE CONCENTRATION FILE.
550 CONTINUE
CALL READIT(ITIME,CONG,NRT,INCHI,IFMT,IEF)
IF(IEF.EQ.l) GO TO 800
C***DETERMINE WHETHER ANY OF THE CONCENTRATIONS FOR THE HOUR ARE LESS
C***THAN ZERO. IF SO, THEN SKIP THE HOUR.
DO 555 I-1,NRT
IF(CONC(I).LT.O.) GO TO 550
555 CONTINUE
C***DECODE THE ITIME ARRAY TO OBTAIN YEAR,MONTH,DAY AND HOUR.
CALL DCODET(ITIME,YEAR,MONTH,DAY,HOUR)
IF(ISEL.NE.3) GO TO 600
C***CALCULATE THE HOUR WITH RESPECT TO 00/01/01:00 .
CALL CHOUR(YEAR,MONTH,DAY,HOUR,IHRT,IFLAG)
IF(IFLAG.EQ.O) GO TO 570
WRITE(*,560) DAY,MONTH,YEAR
560 FORMAT(/,1X,'DAY',13,IX,'NOT CONSISTENT WITH MONTH',13,IX,
&',I3,/,1X,'--HOUR NOT PROCESSED')
GO TO 550
570 IF(IHRT.LT.IHRTS) GO TO 550
IF(IHRT.GT.IHRTF) GO TO 800
C**CONCENTRATION RECORD ACCEPTED FOR PROCESSING.
600 CONTINUE
C***WRITE THE DATE AND TIME TO THE PLOT FILE.
WRITE(OUTCHI,620) IEND,YEAR,MONTH,DAY,HOUR
620 FORMAT(515)
C***SORT RECEPTORS BY CONCENTRATION.
CALL PSORTR(CONC,NRT,NPTR,LPTR)
C***WRITE OUT THE SORTED CONCENTRATIONS WITH THE ASSOCIATED RECEPTOR
C***LOCATIONS.
DO 700 I-NRT,1,-1
C***SKIP OVER RECEPTORS FROM UNWANTED HILLS.
CHI02410
CHI02420
CHI02430
CHI02440
CHI02450
CHI02460
CHI02470
CHI02480
CHI02490
CHI02500
CHI02510
CHI02520
CHI02530
CHI02540
CHI02550
CHI02560
CHI02570
CHI02580
CHI02590
CHI02600
CHI02610
CHI02620
CHI02630
CHI02640
CHI02650
CHI02660
CHI02670
CHI02680-
CHI02690
CHI02700
CHI02710
CHI02720
CHI02730
CHI0274Q_
CHI02750
CHI02760
CHI02770
CHI02780
CHI02790
CHI02800
CHI02810
CHI02820
CHI02830
CH102840
YEARCH102850
CHI02860
CH102870
CHI02880
CH102890
CHI02900
CHI02910
CH102920
CHI02930
CH102940
CHI02950
CH102960
CHI02970
CHI02980
CHI02990
CHI03000
244
-------
IF(IUSE(NPTR(I)).EQ.O) GO TO 700 CHI03010
WRITE(OUTCHI,630) NPTR(I),XREC(NPTR(I)),YREC(NPTR(I)),CONG(NPTR(I)CHI03020
&) CHI03030
630 FORMAT(I5,3E15.4) CHI03040
700 CONTINUE CHI03050
IF(ISEL.EQ.l) GO TO 800 CHI03060
GO TO 550 CHI03070
300 IEND=1 CHI03080
C***WRITE THE END. OF DATA FLAG TO THE PLOT FILE. CHI03090
WRITE(OUTCHI,620) IEND,IZERO,IZERO,IZERO,IZERO CHI03100
GO TO 2000 CHI03110
1000 WRITE(*,1010) CHI03120
1010 FORMAT(/,IX,'***ERROR***NO RECEPTORS FOUND FOR THE HILL1) CHI03130
2000 CONTINUE CHI03140
STOP CHI03150
END CHI03160
245
-------
SUBROUTINE CHOUR(Y,M,D,H,IHRT,IFLAG)
C***CALCULATES THE HOUR TOTAL SINCE 00/01/01:01
C***
c***
C GLOSSARY OF TERMS
C***
c***
C D=TWO DIGIT INTEGER SPECIFYING THE DAY(01-31)
H=TWO DIGIT INTEGER SPECIFYING THE HOUR(01-24)
IDMON(IM)=NUHBER OF DAYS IN MONTH IM IN A NON LEAP YEAR
IDMONL(IM)=NUMBER OF DAYS IN MONTH IM IN A LEAP YEAR
IFLAG=COMPLETION FLAG FOR SUBROUTINE CHOUR
=0(DAY-MONTH ASSIGNMENT WITHIN RANGE)
=1(DAY-MONTHE ASSIGNMENT OUT OF RANGE)
IHRT=HOUR COUNT WITH RESPECT TO 00/01/01:01
M=TWO DIGIT INTEGER SPECIFYING THE MONTH(01-12)
Y=TWO DIGIT INTEGER SPECIFYING THE YEAR(00-99)
C
C
C
C
C
C
C
C
c
c***
c***
INTEGER Y,D,H
DIMENSION IDMON(12),IDMONL(12)
DATA IDMON/31,28,31,30,31,30,31,31,30,31,30,31/
DATA IDMONL/31,29,31,30,31,30,31,31,30,31,30,31/
IFLAG=0
IHRT-0
C***TOTAL HOURS UP TO ALL YEARS UP TO THE CURRENT YEAR.
DO 100 IY=0,Y-1
IF(MOD(IY,4).EQ.O.AND.MOD(IY,100).NE.O) GO TO 10
IHRT-IHRT+8760
GO TO 100
10 IHRT-IHRT+8784
100 CONTINUE
C***TOTAL HOURS FOR ALL MONTHS UP TO THE CURRENT MONTH.
DO 200 IM-1,M-1
IF(MOD(IY,4).EQ.O.AND.MOD(IY,100).NE.O) GO TO 110
IHRT-IHRT+IDMON(IM)*24
GO TO 200
110 IHRT=IHRT+IDMONL(IM)*24
200 CONTINUE
C***CHECK WHETHER THE DAY-MONTH ASSIGNMENT IS CONSISTENT.
IF(MOD(Y,4).EQ.O.AND.MOD(IY,100).NE.O) GO TO 210
IF(D.GT.IDMON(M)) GO TO 400
GO TO 300
210 IF(D.GT.IDMONL(M)) GO TO 400
300 CONTINUE
C***TOTAL HOURS FOR ALL DAYS UP TO THE CURRENT DAY.
IHRT-IHRT+(D-l)*24
C***ADD IN THE HOUR OF THE CURRENT DAY.
IHRT-IHRT+H
RETURN
400 IFLAG-1
RETURN
END
CHR00010
CHR00020
CHR00030
CHR00040
CHR00050
CHR00060
CHR00070
CHR00080
CHR00090
CHR00100
CHR00110
CHR00120
CHR00130
CHR00140
CHR00150
CHR00160
CHR00170
CHR00180
CHR00190
CHR00200
CHR00210
CHR00220
CHR00230
CHR00240
CHR00250
CHR00260
CHR00270
CHR00280
CHR00290
CHR00300
CHR00310
CHR00320
CHR00330
CHR00340
CHR00330-
CHR00360
CHR00370
CHR00380
CHR00390
CHR00400
CHR00410
CHR00420
CHR00430
CHR00440
CHR00450
CHR00460
CHR00470
CHR00480
CHR00490
CHR00500
CHR00510
CHR00520
CHR00530
246
-------
SUBROUTINE DCODET(ITIME,YEAR,MONTH,DAY,HOUR)
C***SUBROUTINE TO DECODE THE ITIME ARRAY TO OBTAIN THE YEAR,MONTH,
C***DAY AND HOUR FOR THE CONCENTRATION.
C***
C***
C GLOSSARY OF TERMS
C***
C***
C DAY=TWO DIGIT INTEGER SPECIFYING THE DAY(01-31)
HOUR=TWO DIGIT INTEGER SPECIFYING THE HOUR(01-24)
ITIME=ARRAY CONTAINING THE YEAR,MONTH,DAY,JULIAN DAY,HOUR, AND
NUMBER ^DF RECEPTORS(IN PACKED FORM) FOR A GIVEN RECORD IN
THE CONCENTRATION FILE
MONTH-TWO DIGIT INTEGER SPECIFYING THE MONTH(01-12)
YEAR=TWO DIGIT INTEGER SPECIFYING THE YEAR(00-99)
C
C
C
C
C
C
c***
C***
INTEGER YEAR,DAY,HOUR
DIMENSION ITIME(4)
C***UNPACK THE YEAR,MONTH,DAY AND HOUR FROM THE ITIME ARRAY AND RETURN.
YEAR-ITIME(l)
MONTH-ITIME(2)/100
DAY=ITIME(2)-MONTH*100
HOUR-ITIME(4)/1000
RETURN
END
DC000010
DCOOQ020
DC000030
DC000040
DCOQQQ50
DC000060
DC000070
DC000080
DC000090
DC000100
DC000110
DC000120
DC000130
DC000140
DC000150
DC000160
DC000170
DC000180
DC000190
DC000200
DC000210
DC000220
DC000230
DC000240
DC000250
DC000260
247
-------
SUBROUTINE PSORTR(ARRAY,NDL,NPTR,LPTR)
C***POINTER SORT USING THE MERGE EXCHANGE METHOD
C***NUMBER OF COMPARISONS=N*LOG(N)/LOG(2)
C***ARRAY=REAL ARRAY TO BE SORTED
C***NDL=NUMBER OF ELEMENTS OF ARRAY TO BE SORTED
C***NPTR=POINTER ARRAY
C***LPTR»WORKING ARRAY
DIMENSION ARRAY(1),NPTR(1),LPTR(1)
C***CHECK INITIAL ORDER
I1=NPTR(1) -
IF(NDL.LE.l.AND.Il.EQ.l) RETURN
IF(Il.LT.l.OR.Il.GT.NDL) GO TO 30
DO 20 1=2,NDL
I2=NPTR(I)
IF(I1.EQ.I2) GO TO 30
IF(I2.LT.1.OR.I2.GT.NDL) GO TO 30
IF(ARRAY(I1).GT.ARRAY(I2)) GO TO 30
11=12
20 CONTINUE
RETURN
C***SET UP POINTER ARRAY
30 DO 40 1=1,NDL
NPTR(I)=I
40 CONTINUE
C***BEGIN THE SORT
IF(NDL.LE.l) RETURN
L2I=1
DO 120 1=1,20
M»l
L2IH-L2I
L2I=2*L2I
IF(L2IH.GT.NDL) GO TO 130
JUP=NDL/L2I+1
DO 110 J=1,JUP
N-M+L2IH
IF(N.GT.NDL) GO TO 110
KLO-M
KUP-MINO(KLO+L2I-1,NDL)
MUP-KLO+L2IH-1
DO 80 K-KLO,KUP
IF(M.GT.NDL) GO TO 50
IF(N.GT.KUP) GO TO 50
IF(M.GT.MUP) GO TO 60
IF(ARRAY(NPTR(M)).GT.ARRAY(NPTR(N)))
50 NL-M
M-M+1
GO TO 70
60 NL-N
N-N+1
70 LPTR(K)-NPTR(NL)
3 0 CONTINUE
90 DO 100 K-KLO,KUP
NPTR(K)=LPTR(K)
100 CONTINUE
M-KLQ+L2I
110 CONTINUE
IF(L2I.GE.NDL) GO TO 130
120 CONTINUE
130 RETURN
END
GO TO 60
SRT00010
SRT00020
SRT00030
SRT00040
SRT00050
SRT00060
SRT00070
SRT00030
SRT00090
SRT00100
SRT00110
SRT00120
SRT00130
SRT00140
SRT00150
SRT00160
SRT00170
SRT00180
SRT00190
SRT00200
SRT00210
SRT00220
SRT00230
SRT00240
SRT00250
SRT00260
SRT00270
SRT00280
SRT00290
SRT00300
SRT00310
SRT00320
SRT00330
SRT00340
SRT0035«-
SRT00360
SRT00370
SRT00380
SRT00390
SRT00400
SRT00410
SRT00420
SRT00430
SRT00440
SRT00450
SRT00460
SRT00470
SRT00480
SRT00490
SRT00500
SRT00510
SRT00520
SRT00530
SRT00540
SRT00550
SRT00560
SRT00570
SRT00580
SRT00590
SRT00600
248
-------
SUBROUTINE READIT(ITIME,CONG,NRT,INCHI,IFMT,IEF) REA00010
C***SUBROUTINE TO READ CONCENTRATIONS FROM AN UNFORMATTED OR FORMATTED REA00020
C***FILE REA00030
C*** REA00040
C*** REA00050
C GLOSSARY OF TERMS REA00060
C*** REA00070
C*** REA00080
C CONC=ARRAY OF NRT CONCENTRATIONS IN THE CONCENTRATION OUTPUT FILE REA00090
C IEF=SUBROUTINE COMPLETION CODE REA00100
C =0(END OF CTDM CONCENTRATION OUTPUT FILE NOT REACHED) REA00110
C ="1(END OF CTDM CONCENTRATION OUTPUT FILE REACHED) REA00120
C IFMT=FORMAT INDICATOR FOR THE CTDM CONCENTRATION OUTPUT FILE REA00130
C -1(FORMATTED) REA00140
C =2(UNFORMATTED) REA00150
C INCHI-UNIT NUMBER FOR THE CTDM CONCENTRATION OUTPUT FILE REA00160
C ITIME=ARRAY CONTAINING THE YEAR,MONTH,DAY,JULIAN DAY,HOUR AND NUMBERREA00170
C OF RECEPTORS(IN PACKED FORM) FOR A PARTICULAR RECORD IN THE REA00180
C CDTM CONCENTRATION OUTPUT FILE REA00190
C NRECPT-NUMBER OF RECEPTORS DETERMINED FROM THE CONCENTRATION OUTPUT REA00200
C FILE FOR A GIVEN RECORD(MUST ALWAYS MATCH NRT) REA00210
C NRT-TOTAL NUMBER OF RECEPTORS IN THE RECEPTOR FILE CORRESPONDING TO REA00220
C THE CONCENTRATION OUTPUT FILE REA00230
C UFL=LOGICAL*1 VARIABLE REA00240
C =.TRUE. IF AN UNDERFLOW HAS OCCURRED REA00250
C =.FALSE. IF AN UNDERFLOW HAS NOT OCCURRED REA00260
C*** REA00270
C*** REA00280
C***THE UNDFL FUNCTION COULD POSSIBLY BE NECESSARY WITH MICROSOFT COMPILREA00290
C*** LOGICAL*! UFL REA00300
DIMENSION CONG(NRT),ITIME(4) REA00310
C*** CALL UNDFL(UFL) REA00320
C***DETERMINE WHETHER THE CTDM CONCENTRATION OUTPUT FILE IS FORMATTED REA00330
C***OR UNFORMATTED. REA00340
IF(IFMT.EQ.2) THEN REA0035(T
C***UNFORMATTED FILE REA00360
READ(INCHI,END-100) ITIME,CONG REA00370
ELSE REA00380
C***FORMATTED FILE REA00390
READ(INCHI,10,END-100) ITIME,NRECPT REA00400
IF(NRECPT.NE.NRT) GO TO 200 . . REA00410
READ(INCHI,20) CONG REA00420
ENDIF REA00430
C***SET END OF FILE CODE TO ZERO AND RETURN. REA00440
IEF-0 REA00450
RETURN REA00460
10 FORMAT(515) REA00470
20 FORMAT(8E10.4) REA00480
C***SET END OF FILE CODE TO 1 AND RETURN. REA00490
100 IEF-1 REA00500
RETURN REA00510
200 WRITE(*,210) NRECPT,NRT REA00520
210 FORMAT(/,IX,'***ERROR***NUMBER OF RECEPTORS FOUND IN THE FORMATTEDREA00530
& CONCENTRATION FILE1,15,/,IX,'IS NOT THE SAME AS THE NUMBER OF RECREA00540
&EPTORS FOUND IN THE RECEPTOR FILE',15) REA00550
STOP REA00560
END REA00570
249
-------
CHIDIS Basic Concentration Display Program
250
-------
10 i********
20 '****•*•***
30 'CHIDIS is a program to show,for a given hour, the locations of receptors
40 'on a map of unedited contours with the receptors being displayed in the
50 'order of decreasing concentration. The user presses the space bar to
60 'display the receptor having the next lowest concentration. At this point,
70 'the user can press the key "C" and have the time, concentration rank,
80 'receptor number, and concentration for the current receptor displayed on
90 'the screen* At any time the user may press the key "N" and have the
100 'concentrations for the next hour displayed. Once the list of receptors
110 'has been exhausted, pressing the space bar will cause the display of
120 'concentrations for the hour to begin repeating. At any time during the
130 'course of the display, the user can press the escape key to terminate
140 'execution of the program.
150 *********
160 '***»****
170 'Clear the screen.
180 CLS
190 'Disable the display of function keys to allow more space for plotting.
210 KEY OFF
220 'Define variables beginning with letters I through N as integers.
240 DEFINT I-N
250 'Dimension the arrays for receptor number, receptor x-coordinate,
270 'receptor y-coordinate, and receptor concentration.
280 DIM NREC(1000),XREC(1000),YREC(1000),CONC(1000)
285 'Dimension the array for storing the plot of digitized unedited contours.
287 DIM IAR(8002)
290 'Set the maximum number of receptors.
300 NRMAX-1000
310 LOCATE 12,15
320 'Input the name of the plot file generated by program FITCON.
330 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
340 'If the specified file does not exist, write a program error message.
350 ON ERROR GOTO 3000
360 OPEN PLOT1S FOR INPUT AS #1
370 'Reset error condition to default.
380 ON ERROR GOTO 0
390 'Make sure that this plot file was generated by program FITCON.
400 INPUT*1, PF$
410 IF PF$-"FITCON" THEN GOTO 490
420 ' Match not found. User asked to try again.
430 LOCATE 10,15
450 PRINT PLOT1$ " IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN"
460 'Close the file which failed the test.
470 CLOSE fl
480 GOTO 310
490 CLS
500 'Input the hill identification number, hill name, hill center coordinates,
510 'number of contours, and the identification numbers for the contours.
511 "The contour identification numbers are actually skipped over and not used.
520 INPUT*1, IDH,HNAME$
530 INPUT*1, XHTOP,YHTOP
540 INPUT*!, NC
550 FOR J-l TO NC
560 INPUT#1, IDC
570 NEXT J
580 'Input the name of the sorted concentration plot file generated by program
590 'CHIRET.
600 LOCATE 12,15
610 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM CHIRET—>";PLOT2$
251
-------
•620 'If the specified file does not exist, write a program error message.
630 ON ERROR GOTO 3100
640 OPEN PLOT2$ FOR INPUT AS #2
650 'Reset error condition to default.
660 ON ERROR GOTO 0
670 'Read the hill identification number and number of receptors from the
680 'sorted concentration file.
690 INPUT#2, IDHILL,NR
700 'DetermineTwhether the hill identification numbers match.
710 IF IDHOIDHILL THEN GOTO 3200
715 'Determine vhether the number of receptors exceeds the maximum allowed.
716 IF NR>NRMAX THEN GOTO 3300
720 'Input x,y boundaries from the FITCON plot file
730 INPUW, XMIN1,XMAX1,YMIN1,YMAX1
735 'Skip over boundaries for edited contours.
736 INPUW, XMIND,XMAXD,YMIND,YMAXD
740 'Input x,y boundaries from the CHIRET sorted concentration plot file.
750 INPUTI2, XMIN2,XMAX2,YMIN2,YMAX2
760 'Use the lowest minima and the highest maxima considering both sets of
765 'boundaries.
770 IF XMINKXMIN2 THEN XMIN-XMIN1 ELSE XMIN-XMIN2
780 IF XMAX1>XMAX2 THEN XMAX-XMAX1 ELSE XMAX-XMAX2
790 IF YMINKYMIN2 THEN YMIN-YMIN1 ELSE YMIN-YMIN2
800 IF YMAX1>YMAX2 THEN YMAX-YMAX1 ELSE YMAX-YMAX2
805 CLS
810 LOCATE 10,22
820 'Select type of display.
830 PRINT "SELECT TYPE OF DISPLAY"
840 PRINT
850 PRINT TAB(22) "1.)
860 PRINT TAB(22) "2.)
870 PRINT
880 INPUT "
890 CLS
900 'Set plot boundaries, scale factors and colors.
910 SCRCX-320. :DSCRX-453. .-SCRCY-104. :DSCRY-1S4 . .-RATIO-1. 3201
920 IF RFLAGt-1 THEN SCRCX-160. .-DSCRX-200. :DSCRY-186. :RATIO-1. 5437
930 'Calculate the coordinates of the center of the display and the
940 'horizontal and veritcal dimensions of the display.
950 XC*(XMIN+XMAX)/2.
960 YO(YMIN+YHAX)/2.
970 DX-XMAX-XMIN
980 DY-YMAX-YMIN
990 IF DX/DY";RFLAG%
252
-------
1120 'Set contour closure indicator to zero. The parameters DUPFLG% and
1130 'IFR are used to allow the plotting of multiple contours at the same
1140 'elevation.
1150 DUPFLG%»0
1160 'Scale first contour point for plotting.
1170 XS1-SCRCX+(X1-XC)*DSCRXDDD
1180 YS1»SCRCY-(Y1-YC)*DSCRYDDD
1190 'Plot the first contour point.
1200 PSET(XS1,Y_S1) , 1C
1210 'Set contour closure counter to zero.
1220 IFR-0
1230 'Begin loop over the remainder of the contour points.
1240 FOR K-2 TO NPC
1250 INPUT*!, X,Y
1260 'If 2 or more contour closures have been reached and the point has the
1270 'same coordinates as the initial point, then skip over the point for
1275 'plotting.
1280 IF IFR>-2 AND ABS(X-X1)<1E-15 AND ABS(Y-Y1)<1E-15 THEN GOTO 1480
1290 'Scale the point X,Y for plotting.
1300 XS-SCRCX+(X-XC)*DSCRXDDD
1310 YS-SCRCY-(Y-YC)*DSCRYDDD
1320 IF DUPFLG*-0 GOTO 1440
1330 'One of the multiple contours has been closed. Move to the new point
1340 "without drawing a line. Substitute the current point for the previous
1350 'individual contour beginning point.
1360 XOLD-X
1370 YOLD-Y
1380 DUPFLG%-0
1390 PSET(XS,Y.S),IC
1400 GOTO 1480
1410 'Determine whether one of the individual multiple contours has been
1420 'closed. If so, set the closure indicator DUPFLG% to 1 and increment
1430 'the contour closure counter IFR by 1.
1440 IF ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG*-!:IFR-IFR+1
1450 'Draw a line from the previous point to the current point.
1460 LINE -(XS,YS),IC
1470 'End loop over contour points.
1480 NEXT K
1490 'Skip over edited contour points.
1500 INPUT*1, NPC,HDUM
1510 FOR K-l TO NPC
1520 INPUTfl, DUMX,DUMY
1530 NEXT K
1540 'End loop over contours.
1550 NEXT J
1560 'Scale hill center coordinates.
1570 XSHOSCRCX+(XHTOP-XC)*DSCRXDDD
1580 YSHOSCRCY-(YHTOP-YC)*DSCRYDDD
1590 XUL-XSHC-1
1600 XLR-XSHC+1
1610 YUL-YSHC-1
1620 YLR-YSHC+1
1630 'Plot a 3x3 box of points centered at the hill center.
1640 LINE(XUL,YUL)-(XLR,YLR),IC,BF
1650 IF RFLAG%-1 THEN GXMX%-319 ELSE GXMX%-639
1660 'Store the plot of digitized contours in array IAR.
1670 GET(0,0)-(GXMX*,199),IAR
1680 'Change color to magenta for plotting receptor points.
1690 IF RFLAG%-1 THEN IC-2
1695 CLS
253
-------
1700 'Read the end-of-data flag and date from the concentration file.
1710 INPUT!2,IEND,IYEAR,MONTH,IDAY,IHOUR
1720 IF IEND-1 THEN SYSTEM
1730 'Read in the receptor number, x-coordinate, y-coordinate, and
1740 "concentration(in the order of descending concentration) for
1750 'for each receptor on the hill in question.
1760 FOR IR-1 TO NR
1770 INPUT#2, NREC(IR),XREC(IR),YREC(IR),CONC(IR)
1780 NEXT IR -
1790 'Write instructions to the screen.
1800 IF RFLAG%-1 THEN LOCATE 8,1 ELSE LOCATE 8,22
1805 PRINT " LIST OF KEYSTROKES"
1810 PRINT
1815 IF RFLAG%-2 THEN LOCATE 10,22
1820 PRINT "Press SPACE for additional receptors"
1825 IF RFLAG%-2 THEN LOCATE 11,22
1830 PRINT "Press C for current concentration"
1835 IF RFLAG%-2 THEN LOCATE 12,22
1840 PRINT "Press N to go to the next hour"
1845 IF RFLAG%-2 THEN LOCATE 13,22
1850 PRINT "Press ESC to leave program"
1855 IF RFLAG%-2 THEN LOCATE 14,22
1860 PRINT
1865 IF RFLAG%-2 THEN LOCATE 16,22
1870 PRINT "Begin by pressing the SPACE bar"
1880 A$-INKEY$
1881 IF A$-CHR$(027) THEN SYSTEM
1882 IF A$<>CHR$(032) THEN GOTO 1880
1890 CLS
1891 'Restore the base map of unedited contours.
1895 PUT(0,0),IAR,PSET
1896 'First select the receptor with the highest concentration.
1900 IR-1
1910 X-XREC(IR):Y-YREC(IR)
1911 'Scale the coordinates of the receptor point for plotting.
1920 XP-SCRCX+(X-XC)*OSCRXOOO
1930 YP-SCRCY-(Y-YC)*DSCRYDDD
1931 'Draw and fill a circle of radius IRAO centered about the receptor point.
1932 'First, blank out the circle if the center of the new circle lies within
1933 'a previously drawn circle.
1935 CIRCLE(XP,YP),IRAD,0
1936 PAINT(XP,YP),0,0
1937 'Now actually draw and fill the circle.
1940 CIRCLE(XP,YP),IRAQ,1C
1950 PAINT(XP,YP),IC,IC
1960 A$-INKEY$:IF A$-CHR$(027) THEN SYSTEM
1970 IF A$-CHR$(078) OR A$-CHR$(110) THEN GOTO 1695 'Read data for a new hour.
1980 IF A$-CHR$(067) OR A$-CHR$(099) THEN GOTO 2000 'Print the concentration
1981 'for the current receptor.
1990 IF A$-CHRS(032) THEN GOTO 2090 'Go to the next point.
1993 'Place a background border around the receptor circle.
1994 CIRCLE(XP,YP),IRAO,0
1995 PAINT(XP,YP),0,0 'Blank out receptor.
1996 GOTO 1940
2000 LOCATE 1,1
2010 FMTS-»f*/#f/**:*f RANKIIi RNUM*## C-#.f#**AAA"
2011 PRINT USING FMT$;IYEAR,MONTH,IDAY,IHOUR,IR,NREC(IR),CONG(IR)
2020 A$-INKEY$
2024 CIRCLE(XP,YP),IRAD,0
2025 PAINT(XP,YP),0,0
254
-------
2030 IF A$-CHR$(027) THEN SYSTEM
2040 IF A$-CHR$(078) OR A$-CHR$(110) THEN GOTO 1695
2050 IF A$=CHR$(032) THEN GOTO 2080
2060 CIRCLE(XP,YP),IRAD,1C
2061 PAINT(XP,YP),IC,IC
2070 GOTO 2020
2071 'Blank out the concentration report line.
2080 LOCATE 1,1
2085 PRINT " "
2090 CIRCL£(XP,YP),IRAD,IC
2091 PAINT(XP,YP),IC,IC
2092 'Increment receptor rank.
2100 IR-IR+1 'Start again with the Rank 1 receptor.
2110 IF IR>NR THEN GOTO 1890
2120 GOTO 1910
2130 SYSTEM
3000 IF ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUND-Press any key"
3010 GOTO 4000
3100 IF ERR-53 THEN PRINT "CHIRET PLOT FILE NOT FOUND-Press any key"
3110 GOTO 4000
3200 PRINT "HILL IDENTIFICATION NUMBERS DO NOT MATCH-Press any key"
3210 GOTO 4000
3300 PRINT "NUMBER OF PRECEPTORS GREATER THAN THE MAXIMUM ALLOWED-Press any key"
4000 A$-INKEY$:IF A$-"" THEN GOTO 4000 ELSE SYSTEM
255
-------
HCHIDIS Hercules'" Version of CHIDIS
256
-------
10 '********
20 '********
30 'HCHIDIS is a program to show,for a given hour, the locations of receptors
40 'on a map of unedited contours with the receptors being displayed in the
50 'order of decreasing concentration. The user presses the space bar to
60 'display the receptor having the next lowest concentration. At this point,
70 'the user can press the key "C" and have the time, concentration rank,
80 'receptor number, and concentration for the current receptor displayed on
90 'the screen.- At any time the user may press the key "N" and have the
100 'concentrations for the next hour displayed. Once the list of receptors
110 'has been exhausted, pressing the space bar will cause the display of
120 'concentrations for the hour to begin repeating. At any time during the
130 'course of the display, the user can press the escape key to terminate
140 'execution of the program. HCHIDIS is a special version of CHIDIS for the
145 'Hercules Graphics Board.
150 '********
160 *********
170 'Clear the screen.
180 CLS
190 'Disable the display of function keys to allow more space for plotting.
210 KEY OFF
220 'Define variables beginning with letters I through N as integers.
240 DEFINT I-N
250 'Dimension the arrays for receptor number, receptor x-coordinate,
270 'receptor y-coordinate, and receptor concentration.
280 DIM NREC(IOOO),XREC(1000),YREC(1000),CONC(1000)
285 'Dimension the array for storing the plot of digitized unedited contours.
287 DIM IAR(15662)
290 'Set the maximum number of receptors.
300 NRMAX-1000
310 LOCATE 12,15
320 'Input the name of the plot file generated by program FITCON.
330 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
340 'If the specified file does not exist, write a program error message.
350 ON ERROR GOTO 3000
360 OPEN PLOT1$ FOR INPUT AS #1
370 'Reset error condition to default.
380 ON ERROR GOTO 0
390 'Make sure that this plot file was generated by program FITCON.
400 INPUTfl, PF$
410 IF PF$-"FITCON" THEN GOTO 490
420 ' Match not found. User asked to try again.
430 LOCATE 10,15
450 PRINT PLOT1S " IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN"
460 'Close the file which failed the test.
470 CLOSE #1
480 GOTO 310
490 CLS
500 'Input the hill identification number, hill name, hill center coordinates,
510 'number of contours, and the identification numbers for the contours.
511 "The contour identification numbers are actually skipped over and not used.
520 INPUTfl, IDH,HNAME$
530 INPUTtl, XHTOP,YHTOP
540 INPUTI1, NC
550 FOR J-l TO NC
560 INPUTfl, IDC
570 NEXT J
580 'Input the name of the sorted concentration plot file generated by program
590 'CHIRET.
600 LOCATE 12,15
257
-------
610 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM CHIRET—>";PLUT2$
620 'If the specified file does not exist, write a program error message.
630 ON ERROR GOTO 3100
640 OPEN PLOT2$ FOR INPUT AS #2
650 'Reset error condition to default.
660 ON ERROR GOTO 0
670 'Read the hill identification number and number of receptors from the
680 'sorted concentration file.
690 INPUTI2, IDHILL,NR
700 'Determine whether the hill identification numbers match.
710 IF IDHoIDHILL THEN GOTO 3200
715 'Determine whether the number of receptors exceeds the maximum allowed.
716 IF NR>NRMAX THEN GOTO 3300
720 'Input x,y boundaries from the FITCON plot file
730 INPUT#1, XMIN1,XMAX1,YMIN1,YMAX1
735 'Skip over boundaries for edited contours.
736 INPUT*1, XMIND,XMAXD,YMIND,YMAXD
740 'Input x,y boundaries from the CHIRET sorted concentration plot file.
750 INPUT!2, XMIN2,XMAX2,YMIN2,YMAX2
760 'Use the lowest minima and the highest maxima considering both sets of.
765 'boundaries.
770 IF XMINKXMIN2 THEN XMIN-XMIN1 ELSE XMIN-XMIN2
780 IF XMAX1>XMAX2 THEN XMAX-XMAX1 ELSE XMAX-XMAX2
790 IF YMINKYMIN2 THEN YMIN-YMIN1 ELSE YMIN-YMIN2
800 IF YMAX1>YMAX2 THEN YMAX-YMAX1 ELSE YMAX-YMAX2
805 CLS
900 'Set plot boundaries and scale factors.
910 SCRCX-360.:DSCRX-490. :SCRCY-180. :DSCRY-327 . .'RATIO-1. 4653
930 'Calculate the coordinates of the center of the display and the
940 'horizontal and veritcal dimensions of the display.
950 XC-(XMIN+XMAX)/2.
960 YO(YMIN+YMAX)/2.
970 DX-XMAX-XMIN
980 DY-YMAX-YMIN
990 IF DX/DY
-------
1250 INPUTtl, X,Y
1260 'If 2 or more contour closures have been reached and the point has the
1270 'same coordinates as the initial point, then skip over the point for
1275 'plotting.
1280 IF IFR>-2 AND ABS(X-X1)<1E-15 AND ABS(Y-Y1)<1E-15 THEN GOTO 1480
1290 'Scale the point X,Y for plotting.
1300 XS-SCRCX+(X-XC)*DSCRXDDD
1310 YS-SCRCY-(Y-YC)*DSCRYDDD
1320 IF DUPFLG%=0 GOTO 1440
1330 'One of the multiple contours has been closed. Move to the new point
1340 'without drawing a line. Substitute the current point for the previous
1350 'individual contour beginning point.
1360 XOLD-X
1370 YOLD-Y
1380 DUPFLG%=0
1390 PSET(XS,YS)
1400 GOTO 1480
1410 'Determine whether one of the individual multiple contours has been
1420 'closed. If so, set the closure indicator DUPFLG% to 1 and increment
1430 'the contour closure counter IFR by 1.
1440 IF ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG%-1:IFR-IFR+1
1450 'Draw a line from the previous point to the current point.
1460 LINE -(XS,YS)
1470 'End loop over contour points.
1480 NEXT K
1490 'Skip over edited contour points.
1500 INPUT!1, NPC,HDUM
1510 FOR K-l TO NPC
1520 INPUTfl, DUMX,DUMY
1530 NEXT K
1540 'End loop over contours.
1550 NEXT J
1560 'Scale hill center coordinates.
1570 XSHOSCRCX+(XHTOP-XC)*DSCRXDDD
1580 YSHOSCRCY-(YHTOP-YC)*DSCRYDDD
1590 XUL-XSHC-1
1600 XLR-XSHC+1
1610 YUL-YSHC-1
1620 YLR-YSHC+1
1630 'Plot a 3x3 box of points centered at the hill center.
1640 LINE(XUL,YUL)-(XLR,YLR),,BF
1660 'Store the plot of digitized contours in array.IAR.
1670 GET(0,0)-(719,347),IAR
1695 CLS
1700 'Read the end-of-data flag and date from the concentration file.
1710 INPUT#2,IEND,IYEAR,MONTH,IDAY,IHOUR
1720 IF IEND-1 THEN SYSTEM
1730 'Read in the receptor number, x-coordinate, y-coordinate, and
1740 'concentration(in the order of descending concentration) for
1750 'for each receptor on the hill in question.
1760 FOR IR-1 TO NR
1770 INPUT#2, NREC(IR),XREC(IR),YREC(IR),CONC(IR)
1780 NEXT IR
1790 'Write instructions to the screen.
1800 LOCATE 8,22
1805 PRINT " LIST OF KEYSTROKES"
1810 PRINT
1815 LOCATE 10,22
1820 PRINT "Press SPACE for additional receptors"
1825 LOCATE 11,22
259
-------
1830 PRINT "Press C for current concentration"
1835 LOCATE 12,22
1340 PRINT "Press N to go to the next hour"
1845 LOCATE 13,22
1850 PRINT "Press ESC to leave program"
1855 LOCATE 14,22
1860 PRINT
1865 LOCATE 16,22
1870 PRINT "Begin by pressing the SPACE bar"
1880 A$-INKEY$
1881 IF A$-CHRS(027) THEN SYSTEM
1882 IF A$OCHR$(032) THEN GOTO 1880
1890 CLS
1891 'Restore the base map of unedited contours.
1895 PUT(0,0),IAR,PSET
1896 'First select the receptor with the highest concentration.
1900 IR-1
1910 X-XREC(IR):Y-YREC(IR)
1911 'Scale the coordinates of the receptor point for plotting.
1920 XP-SCRCX+(X-XC)*DSCRXDDD
1930 YP-SCRCY-(Y-YC)*DSCRYDDD
1931 'Draw and fill a circle of radius IRAO centered about the receptor point.
1932 'First, blank out the circle if the center of the new circle lies within
1933 'a previously drawn circle.
1935 CIRCLE(XP,YP),IRAD,0
1936 PAINT(XP,YP) ,0,0
1937 'Now actually draw and fill the circle.
1940 CIRCLE(XP,YP),IRAD,1
1950 PAINT(XP,YP),1,1
1960 A$-INKEY$:IF A$-CHR$(027) THEN SYSTEM
1970 IF A$-CHR$(078) OR A$-CHR$(110) THEN GOTO 1695 'Read data for a new hour.
1980 IF A$-CHR$(067) OR A$-CHR$(099) THEN GOTO 2000 'Print the concentration
1981 'for the current receptor.
1990 IF A$-CHR$(032) THEN GOTO 2090 'Go to the next point.
1993 'Place a background border around the receptor circle.
1994 CIRCLE(XP,YP),IRAD,0
1995 PAINT(XP,YP),0,0 'Blank out receptor.
1996 GOTO 1940
2000 LOCATE 1,1
2010 FMT$-"##/##/##:f* RANK*** RNUM### Of.#ffAAAA"
2011 PRINT USING FMTS;IYEAR,MONTH,IDAY,IHOUR,IR,NREC(IR),CONC(IR)
2020 A$-INKEY$
2024 CIRCLE(XP,YP),IRAD,0
2025 PAINT(XP,YP),0,0
2030 IF A$-CHR$(027) THEN SYSTEM
2040 IF A$-CHR$(078) OR A$-CHR$(110) THEN GOTO 1695
2050 IF A$-CHR$(032) THEN GOTO 2080
2060 CIRCLE(XP,YP},IRAD,1
2061 PAINT(XP,YP),1,1
2070 GOTO 2020
2071 'Blank out the concentration report line.
2080 LOCATE 1,1
2085 PRINT " "
2090 CIRCLE(XP,YP),IRAD,1
2091 PAINT(XP,YP),1,1
2092 'Increment receptor rank.
2100 IR-IR+1 'Start again with the Rank 1 receptor.
2110 IF IR>NR THEN GOTO 1890
2120 GOTO 1910
2130 SYSTEM
260
-------
3000 IF ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUND-Press any key"
3010 GOTO 4000
3100 IF ERR=53 THEN PRINT "CHIRET PLOT FILE NOT FOUND-Press any key"
3110 GOTO 4000
3200 PRINT "HILL IDENTIFICATION NUMBERS DO NOT MATCH-Press any key"
3210 GOTO 4000
3300 PRINT "NUMBER OF PRECEPTORS GREATER THAN THE MAXIMUM ALLOWED-Press any key"
4000 AS-INKEY$:IF A$-lf" THEN GOTO 4000 ELSE SYSTEM
261
------- |