-------
da
Figure B-3. Trapezoidal Segment for Second Moment Calculation.
• k-1
Contr ibufes a "Negative"
Second Moment
Figure B-4. Hon-Trapezoidal Segments for Contours Crossing the Axis.
66
-------
there can be cases in which D^ and Dfc+i have opposite signs. In this
case, there is no longer a trapezoidal segment, but two right similar
triangles with opposite sides equal to D^ and D^-i-l- If one uses
Equation (B-ll) to calculate the second moment contribution of this
segment, the result will correspond to the difference between the second
moment of the triangle with side D^ and the triangle with side D^^.
As shown in Figure B-4, this negative contribution of the triangle with
side Dfc+i is needed to properly offset a portion of the second moment
associated with the trapezoidal segment having sides D^^ and Dfc+2-
The computation of the total second moment of the contour (about the axis)
obtained through a summation of Equation (B-ll) over k is therefore exact.
B.4 Calculation of the Radius of Gyration of an Ellipse about its Minor
Axis
Consider an ellipse with a semi-minor axis of length, b, and a
semi-major axis of length, a. The equation of this ellipse, with its
major axis along the x-axis and its centroid at the origin, is given by
The second moment, M2, about the minor axis is then given by
M2 - 4j x y dx (B-13)
0
a
4bJ i
o
(B-14))
4
The radius of gyration, Eg, is.therefore,given by
Rg ' (area of^he ellipse) (B~15)
1/2
f • (B-16)
67
-------
APPENDIX C
PROGRAM TEST CASE
68
-------
APPENDIX C
PROGRAM TEST CASE
For the purpose of illustrating the operation of the Terrain
Preprocessor, a single "gullied hill" having 7 closed contours is used.
This example does not exercise the contour completion or multiple contour
(at a single elevation) processing capabilities of program FITCON. These
were tested, however, by the cases run for the CTDM model evaluation
studies.
The file names chosen for this test case (DATCOM, OUTPUT, PLOT1,
COHOUT, PLOT2 and CTDMIH) are arbitrary. Different names could be selected
by the user. To obtain higher resolution plots for this report, the
Hercules™ version of PLOTCON (HPLTCON) has been used.
69
-------
COHTOUR MASTER FILE (DATCON)
70
-------
1 .1000E+02 35
.OOOOE+00 .4000E+01
.OOOOE+00 .2400E+02
.1000E+01 .2800E+02
.2000E+01 .2900E+02
.4000E+01 .3000E+02
.5000E+01 .3000E+02
.8000E+01 .2800E+02
.1000E+02 .2400E+02
.1300E+02 .2300E+02
.1500E+02 .2400E+02
.1700E+02 .2700E+02
.1900E+02 .2900E+02
.2200E+02 .3000E+02
.2400E+02 .3000E+02
.2600E+02 .2900E+02
.2800E+02 .2700E+02
.3000E+02 .2300E+02
.2900E+02 .2200E+02
.2600E+02 .2100E+02
.2100E+02 .1900E+02
.2000E+02 .1700E+02
.2000E+02 .1600E+02
.2100E+02 .1400E-K02
.2200E+02 .1300E+02
.2600E+02 .1000E-K02
.2800E+02 .8000E-K01
.3000E+02 .4000E-K01
.3000E+02 .3000E+01
.2800E+02 .2000E+01
.2400E+02 .2000E+01
.1700E+02 .3000E-H01
.1100E+02 .2000E+01
.5000E+01 .OOOOE+00
.2000E+01 .1000E+01
.OOOOE+00 .4000E+01
2 .2000E+02 32
.1000E+01 .7000E+01
.1000E+01 .2100E+02
.2000E+01 .2500E+02
.3000E+01 .2800E+02
.5000E+01 .2900E+02
.7000E+01 .2700E+02
.9000E+01 .2300E+02
.1200E+02 .2100E+02 -
.1300E+02 .2100E+02
.1600E+02 .2300E+02
.2100E+02 .2800E+02
.2300E+02 .2900E+02
.2700E+02 .2600E+02 .
.2800E+02 .2500E+02
.2800E+02 .2400E+02
.2300E+02 .2400E+02
.2000E+O2 .2300E+02
.1900E+02 .2200E+02
.1800E+02 ' .1800E+02
.1800E+02 .1600E+02
.1900E+02 .1300E+02
.2300E+02 .9000E+01
71
-------
.2600E+02 .6000E+01
.2600E+02 .5000E+01
.2400E+02 .5000E+01
.2100E+02 .6000E+01
.1700E+02 .7000E+01
.1300E+02 .6000E+01
. 1000E-I-02 .5000E+01
.5000E+01 .4000E+01
.3000E+01 .4000E+01
.1000E+01 .7000E+01
3 .3000E+02 27
.2000E+01 .9000E+01
.2000E+01 .2100E+02
.3000E+01 .2500E+02
.5000E+01 .2700E+02
.7000E+01 .2500E+02
.9000E+01 .2100E+02
.1100E+02 .1900E+02
.1300E+02 .1900E+02
.1800E+02 .2400E+02
.2200E+02 .2700E+02
.2500E+02 .2700E+02
.2600E+02 .2500E+02
.2300E+02 .2500E+02
.2000E+02 .2400E+02
.1800E+02 .2200E+02
.1700E+02 .2000E+02
.1600E+02 .1700E-1-02
.1700E+02 .1300E+02
.2000E+02 .1000E+02
.2300E+02 .7000E+01
.2200E-t-02 .7000E-1-01
.1900E+02 .8000E+01
.1600E+02 .9000E+01
.1300E+02 .9000E+01
.7000E+01 .7000E+01
.3000E+01 .7000E+01
.2000E+01 .9000E+01
4 .4000E+02 18
.3000E+01 .1000E+02
.3000E+01 .2100E+02
.4000E+01 .2400E+02
.5000E+01 .2500E+02
.6000E+01 .2400E+02
.8000E+01 .2000E+02
.1000E+02 .1800E+02
.1300E+02 .1700E+02
.14 OOE+02 .1600E+02
.1500E+02 .1300E+02
.1700E+02 .1100E+02
.1800E+02 .1000E+02
.1700E+02 .1000E+02
.1400E+02 .1100E+02
.13 OOE+02 .1100E+02
.8000E+01 .1000E+02
.5000E+01 .9000E+01
.3000E-1-01 .1000E+02
5 .5000E+02 11
.40002+01 .1200E+02
.4000E+01 .2100E+02
72
-------
.5000E+01
.6000E+01
. 8000E+01
.1000E+02
. 1100E+02
.1000E+02
.8000E+01
.5000E+01
.4000E+01
6
.5000E+01
.5000E+01
.6000E+01
.6000E+01
.8000E+01
.9000E+01
.9000E+01
.8000E+01
.6000E+01
.5000E+01
7
.6000E+01
. 6000E+01
.8000E+01
.8000E+01
.7000E+01
.6000E+01
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1400E+02
.1200E+02
.1100E+02
.1100E+02
.1200E+02
.6000E+02
. .1300E+02
.2100E+02
.2100E+02
.1900E+02
.1600E+02
.1500E+02
.1300E+02
.1200E+02
.1200E+02
.1300E+02
.7000E+02
.1400E+02
.1700E+02
.1500E+02
.1400E+02
.1300E+02
.1400E+02
10
73
-------
FITCOH EXECUTION WITH INTERACTIVE INPUT
74
-------
r 1 I UUIN
ENTER CONTOUR MASTER FILE NAME -> DATCON
ENTER DIAGNOSTIC OUTPUT FILE NAME -> OUTPUT
ENTER HILL ID NUMBER(l-99) -> 2
ENTER HILL NAMEC1-15CHAR.) -> BULLIED HILL
INPUT HILL TOP ELEVATION -> 80
INPUT HILL CENTER X-COORDINATE -> 7
INPUT HILL CENTER Y-COORDINATE -> l N
SPECIFY CONTOUR SELECTION MODE
1.) ALL CONTOURS SELECTED
2.) SELECT RANGE OF CONTOUR IDs
3.) INPUT FILE WITH CONTOUR IDs
CHOICE?(1,2,OR 3) -> 1
PLOT REQUESTED?(Y/N) -> Y
ENTER PLOT FILE NAME -> PLOT1
Please wait...Contour data being processed
Contour ID 1 has been accepted
Contour ID S has been accepted
Contour ID 3 has been accepted
Contour ID 4 has been accepted
Contour ID 5 has been accepted
Contour ID 6 has been accepted
Contour ID 7 has been accepted
ENTER FILE NAME FOR FITTED CONTOUR OUTPUT -> CONOUT
Stop - Program terminated.
DJ\>
75
-------
FITCOH DIAGNOSTIC OUTPUT FILE (OUTPUT)
76
-------
HILL NUMBER 2 IS GULLIED HILL
HILL TOP ELEVATION- .8000E+02
HILL CENTER X-COORDINATE- .7000E+01
HILL CENTER Y-COORDINATE- .1450E+02
ALL CONTOURS IN FILE DATCON SELECTED FOR INPUT
CONTOUR ELEVATION FOR CONTOUR ID 1 - .1000E+02
X-Y COORDINATES INPUT FOR CONTOUR ID 1
.OOOOE+00
.OOOOE+00
.1000E+01
.2000E+01
.4000E+01
.5000E+01
.8000E+01
.1000E+02
.1300E+02
.1500E+02
.1700E+02
.1900E+02
.2200E+02
.2400E+02
.2600E+02
.2800E+02
.3000E+02
.2900E+02
.2600E+02
.2100E+02
.2000E+02
.2000E+02
.2100E+02
.2200E+02
.2600E+02
.2800E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.1700E+02
.1100E+02
.5000E+01
.2000E+01
.OOOOE+00
.4000E+01
.2400E+02
.2800E+02
.2900E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.2300E+02
.2400E+02
.2700E+02
.2900E+02
.3000E+02
.3000E+02
.2900E+02
.2700E+02
.2300E+02
.2200E+02
.2100E+02
.1900E+02
.1700E+02
.1600E+02
.1400E+02
.1300E+02
.1000E-t-02
.8000E+01
.4000E+01
.3000E+01
.2000E+01
.2000E+01
.3000E+01
.2000E+01
.OOOOE+00
.1000E+01
.4000E+01
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
X-Y COORDINATES(EDITED) FOR CONTOUR ID
1 - 35
.OOOOE+00
.OOOOE+00
.1000E+01
.2000E+01
.4000E+01
.2400E+02
•2800E+02
.2900E+02
77
-------
.4000E+01
.5000E+01
.8000E+01
.1000E+02
.1300E+02
.1500E+02
.1700E+02
.1900E+02
.2200E+02
.2400E+02
.2600E+02
.2800E+02
.3000E+02
.2900E+02
.2600E+02
.2100E+02
.2000E+02
.2000E+02
.2100E+02
.2200E+02
.2600E+02
.2800E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.1700E+02
.1100E+02
.5000E+01
.2000E+01
.OOOOE+00
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.2300E+02
.2400E+02
.2700E+02
.2900E+02
.3000E+02
.3000E+02
. 2900E+02
.2700E+02
.2300E+02
.2200E+02
.2100E+02
.1900E+02
.1700E+02
.1600E+02
.1400E+02
.1300E+02
.1000E+02
.8000E+01
.4000E+01
.3000E+01
.2000E+01
.2000E+01
.3000E+01
.2000E+01
.OOOOE+00
.1000E+01
,4000E+01
CONTOUR AREA- .6620E+03
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLZPSE PARAMETERS FOR CONTOUR ZO
.1315E+02
.1468E+02
SEMI-MAJOR AXIS LENGTH- .1632E+02
SEMI-MINOR AXIS LENGTH- .1291E+02
ELLIPSE ECCENTRICITY- .6113E+00
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS-120.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID 2 - .2000E+02
X-Y COORDINATES INPUT FOR CONTOUR ID 2
.1000E+01
.1000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01
.9000E+01
.1200E+02
.1300E+02
.1600E+02
.2100E+02
.2300E+02
.70002+01
.2100E+02
.2500E+02
.2800E+02
.2900E+02
.2700E+02
.2300E+02
.2100E+02
.2100E+02
.2300E+02
.2800E+02
.2900E+02
/8
-------
.2700E+02
.2800E+02
.2800E+02
.2300E+02
.2000E+02
.1900E+02
.1800E+02
.1800E+02
.1900E+02
.2300E+02
.2600E+02
.2600E+02
.2400E+02
.2100E+02
.1700E+02
.1300E+02
.1000E+02
.5000E+01
.3000E+01
.1000E+01
.2600E+02
.2500E+02
.2400E+02
.2400E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1300E+02
.9000E+01
.6000E+01
.5000E+01
.5000E+01
.6000E+01
.7000E+01
.6000E+01
.5000E+01
.4000E+01
.4000E+01
.7000E+01
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
X-Y COORDINATES(EDITED) FOR CONTOUR ID
2 -
32
.1000E+01
.1000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01.
.9000E+01
.1200E+02
.1300E+02
.1600E+02
.2100E+02
.2300E+02
.2700E+02
.2800E+02
.2800E+02
.2300E+02
.2000E+02
.1900E+02
.1800E+02
.1800E+02
.1900E+02
.2300E-K02
.2600E+02
.2600E+02
.2400E+02
.2100E+02
.1700E+02
.1300E+02
.1000E-I-02
.5000E+01
.3000E+01
.1000E+01
.7000E+01
.2100E+02
.2500E+02
.2800E+02
.2900E+02
.2700E+02
.2300E+02
.2100E+02
.2100E+02
.2300E+02
.2800E+02
.2900E+02
.2600E+02
.2500E+02
.2400E+02
.2400E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1300E+02
.9000E-I-01
.6000E+01
.5000E+01
.5000E+01
.6000E+01
.7000E+01
.6000E+01
.5000E+01
.4000E+01
.4000E+01
.7000E+01
79
-------
CONTOUR AREA- .3970E+03
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLIPSE PARAMETERS FOR CONTOUR ID
1128E+02
, 1543E+02
SEMI-MAJOR AXIS LENGTH- .1377E+02
SEMI-MINOR AXIS LENGTH- .9175E+01
ELLIPSE ECCENTRICITY- .7458E+00
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS-120.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID 3
X-Y COORDINATES INPUT FOR CONTOUR ID
.3000E+02
•2000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01
.9000E+01
.1100E+02
.1300E+02
.1800E+02
.2200E+02
.2500E+02
.2600E+02
.2300E+02
.2000E+02
.1800E+02
.1700E+02
.1600E+02
.1700E+02
.2000E+02
.2300E+02
•2200E+02
,1900E+02
.1600E+02
.1300E+02
.7000E+01
•3000E+01
.2000E+01
.9000E+01
.2100E+02
.2500E+02
.2700E+02
.2500E+02
.2100E+02
.1900E+02
.1900E+02
.2400E+02
.2700E+02
.2700E+02
.2500E+02
.2500E+02
.2400E+02
.2200E+02
.2000E+02
.1700E+02
.1300E+02
.1000E+02
.7000E+01
.7000E+01
.8000E+01
.9000E+01
.9000E+01
.7000E+01
.7000E+01
.9000E+01
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
X-Y COORDINATES(EDITED) FOR CONTOUR ID
3 - 27
.2000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01
.9000E+01
.1100E+02
.1300E+02
.9000E+01
.2100E+02
.2500E+02
.2700E+02
.2500E+02
.2100E+02
.1900E+02
.1900E+02
30
-------
. 1800E+02
.2200E+02
.2500E+02
.2600E+02
.2300E+02
.2000E+02
. 1800E+02
.1700E+02
. 1600E+02
.1700E+02
.2000E+02
.2300E+02
.2200E+02
.1900E+02
.1600E+02
.1300E+02
.7000E+01
.3000E+01
.2000E+01
. 2400E+02
. 2700E+02
. 2700E+02
. 2500E+02
. 2500E+02
. 2400E+02
. 2200E+02
. 2000E+02
. 1700E+02
. 1300E+02
. 1000E+02
.7000E+01
.7000E+01
.8000E+01
.9000E+01
.9000E+01
.7000E+01
.7000E+01
. 9000E+01
CONTOUR AREA- .2425E+03
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLIPSE PARAMETERS FOR CONTOUR ID
.1010E+02
.1569E+02
SEMI-MAJOR AXIS LENGTH- .1138E+02
SEMI-MINOR AXIS LENGTH- .6782E+01
ELLIPSE ECCENTRICITY- .8030E+00
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS-110.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID
4 - .4000E+02
X-Y COORDINATES INPUT FOR CONTOUR ID
.3000E+01
.3000E+01
.4000E+01
,5000£+01
.6000E+01
.8000E+01
,1000E+02
.1300E+02
.1400E+02
.1500E+02
.1700E+02
,1800E+02
,1700E+02
,1400E+02
.1300E+02
.8000E+01
.5000E+01
.3000E+01
.1000E+02
.2100E+02
.2400E+02
.2500E+02
.2400E+02
.2000E+02
. 1800E-I-02
.1700E+02
.1600E+02
.1300E+02
.1100E+02
.1000E+02
.1000E+02
.1100E+02
.1100E+02
.1000E+02
.9000E+01
.1000E+02
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(.I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
18
81
-------
X-Y COORDINATES(EDITED) FOR CONTOUR ID
.3000E+01
.3000E+01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1300E+02
.1400E+02
.1500E+02
.1700E+02
.1800E+02
.1700E+02
.1400E+02
.1300E+02
.8000E+01
.5000E+01
.3000E+01
.1000E+02
.2100E+02
.2400E+02
.2500E+02
.2400E+02
.2000E+02
.1800E+02
.1700E+02
.1600E+02
.1300E+02
.1100E+02
.1000E+02
.1000E+02
.1100E+02
.1100E+02
.1000E+02
.9000E+01
. 1000E-I-02
CONTOUR AREA- .1190E+03
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLIPSE PARAMETERS FOR CONTOUR ID
.7972E+01
.1532E+02
SEMI-MAJOR AXIS LENGTH- .8283E+01
SEMI-MINOR AXIS LENGTH- .4573E+01
ELLIPSE ECCENTRICITY- .8337E+00
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS- 40.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID 5
X-Y COORDINATES INPUT FOR CONTOUR ID
.5000E+02
.4000E+01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1100E+02
.1000E+02
.8000E+01
.5000E+01
.4000E+01
.1200E+02
.2100E+02
.2300E+02
.2200E+02
. 1800E-I-02
.1600E+02
.1400E+02
.1200E+02
.1100E+02
.1100E+02
.1200E+02
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
X-Y COORDINATES(EDITED) FOR CONTOUR ID
5 -
11
.4000E+01
.4000E+01
.5000E+01
.6000E+01
.1200E+02
.2100E+02
.2300E+02
.2200E+02
-------
8000E+01
•1000E+02
•1100E+02
.1000E+02
.8000E+01
.5000E+01
•4000E+01
.1800E+02
.1600E+02
.1400E+02
.1200E+02
.1100E+02
.1100E+02
.1200E+02
CONTOUR AREA- .5300E+02
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLIPSE PARAMETERS FOR CONTOUR ID
.6679E+01
.1574E+02
SEMI-MAJOR AXIS LENGTH- .5957E+01
SEMI-MINOR AXIS LENGTH- .2832E+01
ELLIPSE ECCENTRICITY- .8798E+00
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS- 20.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID
6 -
.6000E+02
X-Y COORDINATES INPUT FOR CONTOUR ID
.5000E+01
.5000E+01
.6000E+01
.6000E+01
.8000E+01
.9000E+01
.9000E+01
.8000E+01
.6000E+01
.5000E+01
.1300E+02
.2100E+02
.2100E+02
,1900E+02
.1600E+02
, 1500E-I-02
,1300E+02
.1200E+02
•1200E+02
.1300E+02
CONTOUR HAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID
X-Y COORDINATES(EDITED) FOR CONTOUR ID
.5000E+01 .1300E+02
.5000E+01 .2100E+02
.6000E+01 .2100E+02
.6000E+01 .1900E+02
.8000E+01 .1600E-I-02
.9000E+01 .1500E+02
.9000E+01 .13 OOE+02
.8000E+01 .1200E+02
.6000E+01 .1200E+02
.5000E+01 .13 OOE+02
CONTOUR AREA- .2250E+02
X-COORDINATE OF CONTOUR CENTROID-
Y-COORDINATE OF CONTOUR CENTROID-
ELLIPSE PARAMETERS FOR CONTOUR ID
SEMI-MAJOR AXIS LENGTH- .4562E+01
6 - 10
.6585E+01
.1544E+02
83
-------
SEMI-MINOR AXIS LENGTH- .1570E+01
ELLIPSE ECCENTRICITY- ' .9389E+oo
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS- 20.00 DEGREES
CONTOUR ELEVATION FOR CONTOUR ID 7 - .7000E+02
X-Y COORDINATES INPUT FOR CONTOUR ID 7
.6000E+01 .1400E+02
.6000E+01 .1700E+02
.8000E+01 .1500E+02
.8000E+01 .1400E+02
.7000E+01 .1300E+02
.6000E+01 .1400E+02
CONTOUR WAS FOUND TO BE A SINGLE CONTOUR.
(I.E. NO CONTOUR CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT.)
MODIFIED NUMBER OF POINTS FOR CONTOUR ID 7 - 6
X-Y COORDINATES(EDITED) FOR CONTOUR ID 7
.6000E+01 .1400E+02
.6000E+01 .1700E+02
.8000E+01 .1500E+02
.8000E+01 .1400E+02
.7000E+01 .1300E+02
.6000E+01 .1400E+02
CONTOUR AREA- .5000E+01
X-COORDINATE OF CONTOUR CENTROID- .6867E+01
Y-COORDINATE OF CONTOUR CENTROID- .1480E+02
ELLIPSE PARAMETERS FOR CONTOUR ID 7
SEMI-MAJOR AXIS LENGTH- .1764E+01
SEMI-MINOR AXIS LENGTH- .9025E+00
ELLIPSE ECCENTRICITY- .SSSIE+OO
ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE
POSITIVE X-AXIS- 20.00 DEGREES
-------
FITCOH PLOT FILE (PLOT 1)
85
-------
FITCON
2 GULLIED HILL
.7000E+01
7
1
2
3
4
5
6
7
.OOOOE+00
.OOOOE+00
35
.OOOOE+00
.OOOOE+OQ
.1000E+01
.2000E+01
.4000E-I-01
.5000E-I-01
.8000E+01
.1000E+02
.1300E+02
.1500E+02
.1700E+02
.1900E+02
.2200E+02
.2400E+02
.2600E+02
.2800E+02
.3000E-I-02
.2900E+02
.2600E+02
.2100E+02
.2000E+02
.2000E-I-02
.2100E-I-02
.2200E+02
.2600E-I-02
.2800E+02
.3000E-I-02
.3000E+02
.2800E-I-02
.2400E-I-02
. 1700E-I-02
.1100E+02
.5000E+01
.2000E+01
.OOOOE+00
35
.OOOOE+00
.OOOOE+00
.1000E+01
.2000E+01
.4000E+01
.5000E+01
.8000E+01
.1000E+02
.1300E+02
.1450E+02
.3000E+02
.3000E+02
.1000E+02
.4000E+01
.2400E+02
.2800E+02
.2900E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.2300E+02
.2400E+02
.2700E+02
.2900E+02
.3000E+02
.3000E+02
.2900E+02
.2700E+02
<2300E+02
.2200E+02
.2100E+02
.1900E+02
.1700E+02
.1600E+02
.1400E+02
.1300E+02
.1000E+02
.8000E+01
.4000E+01
.3000E+01
.2000E+01
.2000E+01
.3000E+01
.2000E+01
.OOOOE+00
.1000E+01
.4000E+01
.1000E+02
.4000E+01
.2400E+02
.2800E+02
.2900E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.2300E+02
, OOOOE+00
, OOOOE+00
.3000E+02
.3000E+02
86
-------
.1500E+02
.1700E+02
.1900E+02
.2200E+02
.2400E+02
.2600E+02
.2800E+02
.3000E+02
.2900E+02
.2600E+02
.2100E+02
.2000E+02
.2000E+02
.2100E+02
.2200E+02
.2600E+02
.2800E+02
.3000E+02
.3000E+02
.2800E+02
.2400E+02
.1700E+02
.1100E+02
.5000E+01
.2000E+01
.OOOOE+00
32
.1000E+01
.1000E+01
.2000E+01
.3000E+01
.5000E-I-01
.7000E+01
. 9000E-I-01
.1200E+02
.1300E+02
.1600E+02
.2100E+02
.2300E+02
.2700E+02
.2800E+02
.2800E+02
.2300E+02
.2000E+02
.1900E+02
.1800E+02
.1800E+02
.1900E+02
.2300E+02
.2600E+02
.2600E+02
.2400E-I-02
.2100E+02
.1700E+02
.1300E+02
.1000E+02
.5000E+01
.3000E+01
.1000E+01
32
.2400E-I-02
.2700E-I-02
.2900E+02
.3000E+02
.3000E-I-02
.2900E-I-02
.2700E+02
.2300E-I-02
.2200E-I-02
.2100E-I-02
. 1900E-I-02
.1700E+02
.1600E+02
.1400E+02
.1300E-I-02
.1000E+02
.8000E-t-01
.4000E-I-01
.3000E-I-01
.2000E+01
.2000E-I-01
.3000E-I-01
.2000E+01
.OOOOE+OO
.1000E-t-01
.4000E+01
.2000E+02
.7000E+01
.2100E+02
.2500E+02
.2800E+02
.2900E+02
.2700E+02
.2300E-I-02
.2100E+02
.2100E+02
.2300E+02
.2800E+02
.2900E+02
.2600E+02
.2500E+02
.2400E+02
.2400E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1300E+02
.9000E+01
.6000E+01
.5000E+01
.5000E-I-01
. 6000E-I-01
.7000E+01
.6000E+01
.5000E+01
.4000E+01
.4000E+01
.7000E-I-01
.2000E+02
87
-------
.1000E+01
.1000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01
.9000E+01
.1200E-I-02
.1300E+02
.1600E+02
.2100E+02
.2300E+02
.2700E+02
.2800E+02
.2800E+02
.2300E+02
.2000E+02
.1900E+02
.1800E-I-02
.1800E+02
.1900E+02
.2300E+02
.2600E+02
.2600E+02
.2400E+02
.2100E+02
.1700E+02
.1300E+02
.1000E+02
.5000E+01
.3000E+01
.1000E+01
27
.2000E+01
.2000E+01
.3000E+01
.5000E-I-01
.7000E+01
.9000E+01
.1100E+02
.1300E+02
.1800E+02
.2200E+02
.2500E+02
.2600E+02
.2300E-I-02
.2000E+02
. 1800E-I-02
.1700E+02
. 1600E+02
.1700E+02
.2000E-I-02
.2300E+02
.2200E+02
. 1900E+02
. 1600E+02
. 1300E+02
.7000E+01
.3000E+01
.2000E-H01
.7000E+01
.2100E+02
.2500E+02
.2800E+02
.2900E+02
.2700E+02
.2300E+02
.2100E+02
.2100E+02
.2300E+02
.2800E+02
.2900E+02
.2600E+02
.2500E+02
.2400E+02
.2400E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1300E+02
.9000E+01
.6000E-I-01
.5000E+01
.5000E+01
.6000E+01
.7000E+01
.6000E+01
.5000E-I-01
,4000E-I-01
.4000E+01
.7000E+01
.3000E-I-02
.9000E+01
.2100E+02
.2500E+02
.2700E+02
.2500E+02
.2100E+02
.1900E+02
.1900E+02
.2400E+02
.2700E+02
.2700E+02
.2500E+02
.2500E+02
.2400E+02
.2200E+02
.2000E+02
.1700E+02
.1300E+02
.1000E-I-02
.7000E+01
.7000E+01
. 8'OOOE+01
.9000E+01
.9000E+01
.7000E-I-01
.7000E+01
.9000E+01
38
-------
27
.2000E+01
.2000E+01
.3000E+01
.5000E+01
.7000E+01
.9000E+01
.1100E+02
.1300E+02
.1800E+02
.2200E+02
.2500E+02
.2600E+02
.2300E+02
.2000E+02
.1800E+02
.1700E+02
.1600E+02
.1700E+02
.2000E+02
.2300E+02
.2200E+02
.1900E+02
.1600E+02
.1300E+02
.7000E+01
.3000E+01
.2000E+01
19
.3000E+01
.3000E-I-01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1300E+02
.1400E+02
.1500E+02
.1700E+02
.1800E+02
.1700E+02
.1400E+02
.1300E+02
.8000E+01
.5000E+01
.3000E+01
18
.3000E+01
.3000E+01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1300E+02
.1400E+02
.1500E+02
.1700E+02
.1800E+02
.3000E+02
.9000E+01
.2100E+02
.2500E+02
.2700E+02
.2500E+02
.2100E+02
.1900E+02
.1900E+02
.2400E+02
.2700E+02
.2700E+02
.2500E+02
.2500E+02
.2400E+02
.2200E+02
.2000E+02
.1700E+02
.1300E+02
.1000E+02
.7000E+01
.7000E+01
.8000E-I-01
.9000E+01
.9000E+01
.7000E+01
.7000E+01
.9000E+01
.4000E+02
.1000E+02
.2100E+02
.2400E+02
.2500E+02
.2400E+02
.2000E+02
.1800E+02
.1700E+02
.1600E+02
.1300E+02
.1100E+02
.1000E+02
.1000E+02
.1100E-I-02
.1100E+02
.1000E+02
.9000E+01
.1000E+02
.4000E+02
.1000E+02
.2100E+02
.2400E+02
.2500E+02
.2400E+02
.2000E+02
.1800E+02
.1700E+02
.1600E+02
.1300E+02
.1100E+02
.1000E+02
89
-------
.1700E+02
.1400E+02
.1300E+02
.8000E+01
.5000E+01
.3000E+01
11
.4000E+01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1100E+02
.1000E+02
.8000E+01
.5000E+01
.4000E+01
11
.4000E+01
.4000E+01
.5000E+01
.6000E+01
.8000E+01
.1000E+02
.1100E+02
.1000E+02
.8000E+01
.5000E+01
.4000E+01
10
.5000E+01
.5000E+01
.6000E+01
.6000E+01
.8000E+01
.9000E+01
.9000E+01
.8000E+01
.6000E+01
.5000E+01
10
.5000E+01
.5000E+01
.6000E+01
.6000E+01
.8000E+01
.90002+01
.9000E+01
.8000E+01
.6000E+01
.5000E+01
6
.6000E+01
.6000E+01
.8000E+01
.8000E+01
.7000E-I-01
.6000E+01
6
.1000E+02
.1100E+02
.1100E+02
.1000E+02
.9000E+01
.1000E+02
.5000E+02
.1200E+02
.2100E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1400E+02
.1200E+02
.1100E+02
.1100E+02
.1200E+02
.5000E+02
.1200E+02
.2100E+02
.2300E+02
.2200E+02
.1800E+02
.1600E+02
.1400E+02
.1200E+02
.1100E+02
.1100E+02
.1200E+02
.6000E+02
.1300E+02
.2100E+02
.2100E+02
.1900E+02
.1600E+02
.1500E+02
.1300E+02
.1200E+02
.1200E+02
.1300E+02
.6000E+02
.1300E+02
.2100E+02
.2100E+02
.1900E+02
.1600E+02
.1500E+02
.1300E+02
.1200E+02
.1200E+02
.1300E+02
.7000E+02
.1400E+02
.1700E+02
.1500E+02
.1400E+02
. 1300E-I-02
.1400E+02
.7000E+02
90
-------
6000E+01
6000E+01
8000E+01
8000E+01
7000E+01
6000E+01
1315E+02
1128E+02
1010E+02
7972E+01
6679E+01
6585E+01
6867E+01
.1400E+02
.1700E+02
. 1500E+02
.1400E+02
.1300E+02
.1400E+02
. 1468E+02
. 1543E+02
.1569E+02
.1532E+02
. 157.4E+02
. 1544E+02
. 1480E+02
. 1632E+02
.1377E+02
. 1138E+02
.8283E+01
.5957E-H01
.4562E+01
.1764E+01
.1291E+02
.9175E-H01
. 6782E+01
.4573E+01
.2832E+01
.1570E+01
.9025E+00
.1200E+03
.1200E+03
.1100E+03
.4000E+02
.2000E+02
.2000E+02
.20003+02
-------
FITCOH OUTPUT FILE FOR HCRIT INPUT (CONOUT)
92
-------
B GULLIED HILL
.BOOOE+O8
7
1
2
3
5' . •
6
7
. 1000E+08 . 1319E+08 . 146BE+08 . 1638E+OS .1891E+Oe .6113E+00 . 120OE+03
.EOOOE+Oe .118BE+O8 . 13A3E+08 .1377E+O8 .917SE+O1 .7
-------
HCRIT EXECUTION WITH INTERACTIVE INPUT
-------
A:\T£RRAIN>HCRIT
ENTER INPUT PILE NAME(FROM FITCON) -> CONOUT
ENTER OUTPUT FILE NAME(FOR CTDM) ->TERRAIN
PLOT REQUESTED?(Y/N) -> Y
ENTER PLOT FILE NAME -> PLOT2
SPECIFY CRITICAL HEIGHT SELECTION MODE
1.) AT ALL CONTOUR ELEVATIONS EXCEPT UPPERMOST
2.) EVENLY SPACED BETWEEN A USER SUPPLIED ELEVATION
AND THE UPPERMOST CONTOUR ELEVATION
CHOICE?(1 OR 2) -> 1
A:\TERRAIN>
95
-------
HCRIT PLOT FILE (Plot 2)
96
-------
NCR IT
a GULLIED HILL
7
I
e
3
*
3
&
7
.BOOOE+OB
. IOOOE+OB
.BOOOE+OB
.3OOOE+OB
.4OOOE+OB
.3OOOE+OB
.&OOOE+OB
.7000E+OB
.
. 1OOOE+O8 .BB<»7E+OI . 13<»OE+OB .4B6BE+O8 . 1791E+O1 .I467E+O1 .AB93E+O1 .3333E+O1
.BOOOE+Oe .7641E+O1 . 13<»OE+OB .37<»3C+OS . I799E+O1 . 13<*OE+OI .93B3E+OI .S62^E+01
.3000E+03 .7086E+01 . 1332E+OB .B<»7IE+OB . 1B33E>O1 . 1676E>O1 .<»<»6<»E+O1 .BO7OE+O1
.OB .BOOOE+OB .1BO3E+O1 .19BIE+OI .3633E+O1 . 1589E+O1
.3000E+OB .67B6E+01 . 131BE>OB .BQOOE^OB .!<»99E-fOl .BSO'.E+Ol .BB37E+O1 . 119OE+O1
.6000E+OB .6B67E+01 . 1<»BOE+OB .BOOOE+OB .BOOOE+OI .BOOOE+O1 .1764E+01 .9OB5E+OO
-------
HCRIT OUTPUT FILE FOR INPUT TO CTDH (TERRAIN)
98
-------
2 6
10.000
20.000
30.000
40.000
50.000
60.000
10.000
20.000
30.000
40.000
50.000
.1315E+02
. 1128E-I-02
.1010E+02
.7972E+01
.6679E+01
.6585E+01
.8247E+01
.7641E+01
.7026E+01
.6710E+01
.6726E+01
. 8000E-I-02
.1468E+02
.1543E+02
.1569E+02
.1532E+02
.1574E+02
.1544E+02
.1540E+02
.1540E+02
.1532E+02
. 1533E+02
. 1512E+02
GULLIED HILL
60.
60.
70.
140.
160.
160.
131.
142.
155.
160.
160.
000
000
000
000
000
000
319
548
290
000
000
16.
13.
11.
s:
5.
4.
1.
1.
1.
1.
1.
320
770
380
283
957
562
791
799
853
805
459
12.
9.
6.
4.
2.
1.
1.
1.
1.
1.
2.
910
175
782
573
832
570
467
540
676
921
504
6
5
4
3
2
.295
.383
.464
.633
.837
3.233
2.624
2.070
1.589
1.190
60.000 .6867E+01 .1480E+02 160.000 2.000 2.000 1.764* .902
-------
PLOTCON (HPLTCON) EXECUTION WITH INTERACTIVE INPUT
100
-------
D:\>PLOTCON"
INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>? PLOT1
SELECT TYPE OF DISPLAY
1.) Low resolution with color
2.) High resolution black and whits
Choic«?(l or 2)—>? 2
SELECT THE CONTOUR TYPE FOR DISPLAY
1.) Un«dit»d Contours
2.) Edited Contours
Choice?U or 2)—>? 2
DISPLAY FITTED CUTOFF HILL CONTOURS?(Y/N)->? Y
INPUT NAME OF PLOTFILE FROM PROGRAM HCRIT? PLOT2
101
-------
PLOT OF ACTUAL INPUT CONTOURS
102
-------
103
-------
PLOT OF ACTUAL CONTOURS AND FITTED ELLIPSES
104
-------
105
-------
PLOT OF ACTUAL CONTOURS AND INVERSE POLYNOMIAL
CONTOURS AT ACTUAL CONTOUR ELEVATIONS
ABOVE THE CRITICAL CUTOFF ELEVATION
106
-------
o
a
CB
u
107
-------
0
CM
o
a
a>
i-i
u
a
u
u
108
-------
«0
I
*•*
cu
to
o
109
-------
o
(9
-------
o
in
o
cu
B
U
u
111
-------
o
vO
O
a
4)
!•*
cu
«5
U
(4
u
112
-------
APPENDIX D
PROGRAM LISTINGS
113
-------
FITCOH MAIN PROGRAM AND SUBROUTINES
114
-------
PROGRAM FITCON
C***PROGRAM TO FIT DIGITIZED CONTOURS TO ELLIPTICAL SHAPES. PROGRAM
C***C£NERATES A FILE OF ELLIPTICAL CONTOUR PARAMETERS TO BE USED BY
C***PROGRAM HCRIT TO PERFORM THE CRITICAL HEIGHT ANALYSIS FOR THE
C***HILL IN QUESTION. A PLOT FILE IS ALSO GENERATED FOR SUBSEQUENT
C***DISPLAY OF DIGITIZED AND FITTED CONTOURS.
C***
C GLOSSARY OF TERMS
C A(J)-CALCULATED SEMI-MAJOR AXIS LENGTH(USER COORDINATES) FOR THE
C ELLIPTICAL REPRESENTATION OF CONTOUR J
C AFIL-ANGULAR FILTER SIZE(1 TO 22.5 DEGREES) INPUT BY THE USER
C FOR THE CONTOUR COMPLETION ANALYSIS. MODIFIED AFTER INPUT
C SO THAT IT DIVIDES EVENLY INTO 360 DEGREES.
C ANGLE(M)-(M-1)*10.0 WHERE M-1,18
C ANS-CHARACTER*! VARIABLE HOLDING THE ANSWER TO A YES(Y) OR NO(N)
C QUESTION
C AR-VALUE OF THE AREA RETURNED BY A CALL TO SUBROUTINE ARCM.
C AR WILL BE POSITIVE IF THE CONTOUR POINTS ARE GIVEN IN A '
C CLOCKWISE FASHION AND NEGATIVE IF THE CONTOUR POINTS ARE GIVEN
C IN A COUNTER-CLOCKWISE FASHION
C .ARCH-SUBROUTINE TO CALCULATE THE CONTOUR AREA AND CENTROID
C COORDINATES
C AREA-AREA OF A GIVEN CONTOUR(-ABS(AR))
C B(J)-CALCULATED SEMI-MINOR AXIS LENGTH(USER COORDINATES) FOR THE
C ELLIPTICAL REPRESENTATION OF CONTOUR J
C CTLAG-CONTOUR CLOSURE INDICATOR
C -0(CONTOUR OPEN)
C -1(CONTOUR CLOSED)
C CH(M)-COS(PI*(M-l)*10.0/180.) WHERE M-1,18
C CONIN-UNIT NUMBER FOR FILE CONTAINING CONTOUR IDs FOR THE HILL
C IN QUESTION
C CONFILE-CHARACTER*15 VARIABLE GIVING THE NAME OF THE FILE
C CONTAINING CONTOUR IDs FOR THE HILL IN QUESTION
C CONCOMP-SUBROUTINE WHICH ADDS POINTS TO COMPLETE A CONTOUR
C COOT-UNIT NUMBER FOR OUTPUT FILE COUTFILE WHICH WILL BE INPUT TO
C THE CRITICAL HEIGHT ANALYSIS PROGRAM
C COUTFIL£-CHARACTER*15 VARIABLE GIVING THE NAME OF THE OUT&JT FILE
C CONTAINING THE FITTED HILL PARAMETERS WHICH WILL BE INPUT
C TO THE CRITICAL HEIGHT ANALYSIS PROGRAM(HCRIT)
C DFTOL-DISTANCE FROM FIRST TO LAST CONTOUR POINT(USER COORDINATES)
C DOUT-UNIT NUMBER FOR FILE CONTAINING DIAGNOSTIC OUTPUT
C DOUTFILE-CHARACTER*15 VARIABLE GIVING THE NAME OF THE FILE
C CONTAINING DIAGNOSTIC OUTPUT FOR THE HILL IN QUESTION
C ECC(J)-ECCENTRICITY OF THE ELLIPSE REPRESENTING CONTOUR J
C -SQRT(A(J)**2-B(J)**2)/A(J)
C HCON(J)-ELEVATION OF HILL CONTOUR J(USER COORDINATES)
C HCONT-VALUE OF HCON(J) FOR A PARTICULAR CONTOUR J
C HNAME-CHARACTER*15 VARIABLE GIVING THE RILL NAME
C HTOP-HILL TOP ELEVATION(USER COORDINATES)
C ICL-SMALLEST ID(1-9999) NUMBER FOR THE CONTOUR GROUP(INPUT ONLY FOR
C ICMODE-2)
C ICMODE-CONTOUR INPUT MODE FOR THE HILL IN QUESTION
C -1(ALL CONTOURS IN THE MASTER FILE SELECTED FOR INPUT)
C -2(CONTOUR ID RANGE SPECIFIED FOR INPUT)
C -3(INPUT FILE WITH CONTOUR IDs SPECIFIED)
C ICU-LARGEST ID NUMBER(1-9999) FOR THE CONTOUR GROUP(INPUT ONLY FOR
C ICMODE-2)
FIT00010
FIT00620
FIT00030
FIT00040
FITOOpSO
FIT00660
FIT90070
FITOOdSO
FITOOU90
FIT00100
FITOOllO
FITOO:i20
FTTOO:L30
FITOO:L40
FIT00150
FITOO!L60
FIT00170
FITOOPSO
FIT00190
FIT00200
FIT00210
FIT00220
FTT00230
FIT00240
FIT00250
Firoo^eo
FITOOJ70
FITOO280
FIT00290
FITOO)oo
FITOO?10
FTT00320
FTT00330
FTT00340
FITOO!} 50
FIT00360
FIT00370
FITOO JJ 80
FIT00390
FTT00400
FIT00410
FIT00420
FITOO430
FIT00440
FIT00450
FIT00460
FIT00470
FIT00480
FIT00490
FITOO
FITOO
FITOO
FITOO
FITOO
FITOO
00
10
20
30
40
50
FIT00560
FITOO?70
FITOOPSO
FIT00590
FIT00600
115
-------
C IDC(J)-ID NUMBER FOR CONTOUR J WHICH HAS BEEN SELECTED FROM THE FIT00610
C CONTOUR MASTER FILE FIT00620
C IDCPK(I)-ID NUMBER FOR THE Ith CONTOUR SPECIFIED IN FILE CONFILE FIT00630
C IDHILL-HILL ID NUMBER(l-999) SPECIFIED BY THE USER FIT00640
C IN-UNIT NUMBER FOR CONTOUR MASTER FILE FIT00650
C ISMFLG-COHPLETION CODE RETURNED BY SUBROUTINE SMOMNT FIT00660
C -0(RADIUS OF GYRATION WAS CALCULATED) FIT00670
C -1(RADIUS OF GYRATION COULD NOT BE CALCULATED) FIT00680
C J-CURRENT NUMBER OF CONTOURS INPUT FROM THE MASTER FILE FOR THE FIT00690
C HILL IN QUESTION(AFTER QUALIFICATION AND EDITING) FTT00700
C LTPR-WORKING ARRAY USED BY SUBROUTINE ISORT FIT00710
C MASTER-CHARACTER*15 VARIABLE GIVING THE NAME OF THE MASTER FILE FIT00720
C CONTAINING THE CONTOUR ELEVATIONS AND POINT COORDINATES FIT00730
t MCFLAG-MULTIPLE CONTOUR SUBROUTINE COMPLETION CODE RETURNED FROM FIT00740
C SUBROUTINE MULTC FIT00750
C -0(MAXIMUM NUMBER OF POINTS EXCEEDED IN THE CONTOUR POINT FIT00760
C REASSIGNMENT PROCESS—CONTOUR REJECTED) FIT00770
C . -1(THE LAST IN A SERIES OF MULTIPLE CONTOURS WAS FOUND NOT FIT00780
C TO BE CLOSED—CONTOUR REJECTED) FIT00790
t . -2(CONTOUR WAS FOUND TO BE A SINGLE CONTOUR(I.E. NO CONTOUR FIT00800
C CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT)) FIT00810
C -3(POINT REASSIGNMENT FOR THE MULTIPLE CONTOUR WAS FIT00820
C SUCCESSFULLY COMPLETED) FIT00830
C HOTOTAL NUMBER OF CONTOURS SELECTED FROM THE MASTER FILE FOR THE FIT00840
C HILL IN QUESTION FTT00850
t HCID-NUMBER OF REQUESTED CONTOUR IDs CONTAINED IN CONFILE FIT00860
C HCMAX-MAXIMUM NUMBER OF CONTOURS ALLOWED FIT00870
C MCT2-2*NC FIT00880
C MFIL-INT(3«0./AFIL) FIT00890
C MPC-NUMBER OF POINTS ON A CONTOUR . FIT00900
C VPCMAX-MAXIMUM NUMBER OF POINTS PER CONTOUR ALLOWED FIT00910
C FPCSV-NUMBER OF POINTS ON A CONTOUR PRIOR TO CONTOUR COMPLETION FIT00920
6 HSLOPE-HUMBER OF LINES USED IN THE DETERMINATION OF THE LINE, FIT00930
C PASSING THROUGH THE CONTOUR CENTROID, WHICH GIVES THE FIT00940
C MAXIMUM RADIUS OF GYRATION FOR THE DIGITIZED CONTOUR FIT00950
t OREN(J)-ANGLE CORRESPONDING TO THE ORIENTATION OF THE SEMI- FTT00960
C MINOR AXIS OF CONTOUR J. THE POSSIBLE ORIENTATIONS REPRESENTFIT00970
t THE FOLLOWING DIRECTIONS WITH RESPECT TO THE POSITIVE FIT00980
C' X-AXXS:0,10,20,30,40,30,60,70,80f90,100,110,120,130,140,150,FIT00990
C 160,AND 170 DEGREES FIT01000
t ORENT-CONTOUR MINOR AXIS ORIENTATION CORRESPONDING TO THE MAXIMUM FIT01010
C RADIUS OF GYRATION RETURNED BY SUBROUTINE SMOMNT. ORENT IS FIT01020
C SIMPLY A TEMPORARY HOLDING VARIABLE FOR OREM(J) FIT01030
C PI-3.14159265 FIT01040
C PFILE-CHARACPER*15 VARIABLE GIVING THE NAME OF THE PLOT FILE FIT01050
C PFLAG-PLOT GZNERATON INDICATOR FIT01060
C -0(NO PLOT GENERATED) • FIT01070
-1(PLOT GENERATED) FIT01080
RAD-RADIUS OF THE EQUIVALENT CIRCULAR CONTOUR(USER COORDINATES) FIT01090
RG-MAXIMUM RADIUS OF GYRATION CONSIDERING THE 18 ORIENTATIONS OF FIT01100
AXES PASSING THROUGH THE CONTOUR CENTROID IN THE PLANE OF FIT01110
THE CONTOUR(USER COORDINATES) * FIT01120
RGRAT-THE RATIO OF THE DIFFERENCE BETWEEN THE MAXIMUM AND MINIMUM FIT01130
RADII OF GYRATION(CONSIDERING THE 18 ORIENTATIONS OF AXES FIT01140
PASSING THROUGH THE CONTOUR CENTROID) TO THE MAXIMUM RADIUS FIT01150
C OF GYRATION. USED TO DETERMINE WHETHER AN INPUT CONTOUR SHOULDFIT01160
C BE REPRESENTED BY A CIRCLE FIT01170
C SKIPCN-SUBROUTINE TO SKIP OVER CONTOUR POINTS FOR CONTOURS WHICH AREFIT01180
C NOT PROCESSED . FIT01190
C SMOMNT-SUBROUTINE WHICH CALCULATES THE MAXIMUM RADIUS OF GYRATION FIT01200
116
-------
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
•c
c
c
c
c
c
c
c
c
c
c
c
c
c
c***
c***
FOR AM INPUT CONTOUR BY CONSIDERING THE CALCULATED RADII OF FIT01210
GYRATION FOR 18 LINES OF EQUAL ANGULAR SPACING WHICH PASS FIT01220
THROUGH THE CONTOUR CENTROID IN THE PLANE OF THE CONTOUR FIT01230
SN(M)-SIN(PI*(M-l)*10.0/180.) WHERE M-1,18 FIT01^40
ISORT-SUBROUTINE TO CARRY OUT A SIMPLE PARAMETER SORT FIT01250
UPL-ONIT NUMBER FOR THE FILE PFILE FIT01260
UPSCR-UNIT NUMBER FOR THE SCRATCH FILE "PSCRAT" FITOIJTO
XOCONTOUR CENTROID X-COORDINATE RETURNED BY A CALL TO ARCM. FIT01280
XC IS SIMPLY A TEMPORARY HOLDING VARIABLE FOR XCM(J) FIT01290
XCM(J)-CALCULATED X-COORDINATE(USER COORDINATES) OF THE CENTER OF FIT01300
MASS OF CONTOUR J FIT01310
XCON(K)-X-COORDINATE
-------
C*** FIT01810
!C* "INITIALIZE THE ANGLE ARRAY TO BE USED FOR THE CONTOUR FIT01820
^•••ORIENTATION ANALYSIS. " ' FIT01830
DATA ANGLE/0.,10.,20.,30.,40.,50.,60.,70.,80.,90.,100.,110., FIT01840
&120.,130.,140.,ISO.,160.,170./ FIT01850
C***INITIALIZE SINE AND COSINE ARRAYS TO BE USED FOR THE CONTOUR FIT01860
C***ORIENTATION ANALYSIS. FIT01870
DATA SN/0.,0.1736,0.3420,0.5,0.6428,0.7660,0.8660,0.9397, FIT01880
40.9848,1.0,0.9848,0.9397,0.8660,0.7660,0.6428,0.5,0.3420,0.1736/ FIT01890
DATA CN/1.0,0.9848,0.9397,0.8660,0.7660,0.6428,0.5,0.3420,0.1736, FIT01900
&0.0,-0.1736,-0.3420,-0.5,-0.6428,-0.7660,-0.8660,-0.9397,-0.9848/ FIT01910
C***SPECIFY FILE UNIT NUMBERS. FIT01920
CONIN-14 FIT01930
IN-1S FIT01940
DOUT-1S FIT01950
COUT-17 FIT01960
UPL-18 FIT01970
UPSCR-19 FIT01980
'C***SPECIFY CONSTANTS. FIT01990
PI-3.14159265 FIT02000
NCMAX-200 . FIT02010
NPCMAX-1000 FIT02020
NSLOPE-18 FIT02030
C*** FIT02040
C*** . FIT02050
C INPUT FILE NAMES(MASTER FILE AND DIAGNOSTIC OUTPUT FILE) AND FIT02060
C HILL IDENTIFICATION INFORMATION. FIT02070
C*** FIT02080
C*** FIT02090
;C***INPUT NAMES FOR THE CONTOUR MASTER FILE AND THE DIAGNOSTIC FIT02100
C***OUTPUT FILE. . FIT02110
! 5 WRITE(*,10) • FIT02120
! 10 FORMAT(/,IX,'ENTER CONTOUR MASTER FILE NAME -> «\) FIT02130
READ(*,'(A)•) MASTER ' FIT02140
IF(MASTER.EQ.' •) GO TO 5 . FIT02150
1 15 WRITE(*,20) . FTT02160
20 FORMAT(/,IX,'ENTER DIAGNOSTIC OUTPUT FILE NAME -> *\) FIT02170
READ(*,'(A)') DOUTFILE ' FIT02180
!* IF(DOUTFILE.EQ.• •) GO TO 15 FIT02190
C***OPEN THE CONTOUR MASTER FILE AND THE DIAGNOSTIC OUTPUT FILE. FIT02200
OPEN(IH,FILE-MASTER,STATUS-'OLD') FIT02210
OPEH(DOUT,FILE-DOUTFILE,STATUS-'NEW') FIT02220
;C***INPUT HILL IDENTIFIER NUMBER AND HILL NAME. FIT02230
! 25 WRITE(*,30) FIT02240
30 FORMAT(/,IX,'ENTER HILL ID NUMBER(1-99) -> >\) FIT02250
READ(*,'(BN,I2)',ERR-25) IDHILL FIT02260
! IF(IDHILL.EQ.O) GO TO 25 - FIT02270
! 35 WRITE(*,40) FIT02280
40 FORMAT(/,IX,'ENTER HILL NAME(1-15CHAR.) -> «\) FIT02290
READ(*,'(A)') HNAME FIT02300
IF(HNAME.EQ.' •) GO TO 35 FIT02310
WRITE(DOUT,50) IDHILL,HNAMB • . FIT02320
50 FORHAT(/,1X,'HILL NUMBER',I4,1X,'IS',1X,A15) FIT02330
C*** FIT02340
C*** FIT023SO
C INPUT THE HILL TOP ELEVATION AND THE COORDINATES OF THE FIT02360
C HILL CENTER. FIT02370
C*** • FIT02380
C*** FIT02390
C***INPUT THE HILL TOP ELEVATION. FIT02400
118
-------
60 CONTINUE
WRITE(*,70)
70 FORMAT(/,IX,'INPUT HILL TOP ELEVATION -> '\)
READ(*,'(BN,F10.0)',ERR-60) HTOP
C***INPOT THE HILL CENTER X AND Y COORDINATES.
80 WRITE(*, HO)
110 FORMAT(/,IX,'INPUT HILL CENTER X-COORDINATE -> •
READ(*,'(BN,F10.0)',ERR-80) XHTOP
115 WRITE(*,120)
120 FORMAT(/,IX,'INPUT RILL CENTER Y-COORDINATE -> '
READ(*,'(BN,F10.0)»,ERR-115) YHTOP
C***DETERMINE WHETHER ANGULAR FILTERING IS TO BE USED.
WRITE(*,1201)
1201 FORMAT(/,IX,'ANGULAR FILTERING?(Y/N) -> -\)
READ(*,'(A)') ANS
IF(ANS.EQ.'Y'.OR.ANS.EQ.'y') GO TO 1202
NFIL-0
GO TO 1261
1202 CONTINUE
\)
\)
FIT02410
FIT024*0
FIT024JO
FIT02440
FIT02450
FIT02460
FTT02470
FIT024IO
FIT02490
FIT02500
FIT02510
FIT02520
FIT02530
FIT02540
FIT02S50
FIT02560
FIT02570
FIT02580
FIT02590
C***INPOT ANGULAR FILTER SIZE FOR USE IN THE CONTOUR COMPLETION ANALYSISFIT02600
121 WRITE(*,122) FIT02610
122 FORMAT(/,IX,'INPUT ANGULAR FILTER SIZE FOR CONTOUR COMPLETION(1-22FIT02620
«.5 DEC.) -> «\) FIT02630
READ(*,'(BN,F10.0)',ERR-121) AFIL FIT02640
IF(AFIL.GE.1.0.AND.AFIL.LE.22.5) GO TO 124 FIT02630
WRITE(*,123) FIT02660
123 FORMAT(/,IX,'***ERROR*** SPECIFIED FILTER SIZE OUT OF RANGE—TRY AFIT02670
*GAHt«) FIT02680
GO TO 121 FIT02690
C***WRTTE SPECIFIED ANGULAR FILTER SIZE TO THE DIAGNOSTIC OUTPUT FILE. FTE02700
124 WRITE(DOOT,123) AFIL FIT02710
125 FORMAT(/,IX,'SPECIFIED ANGULAR FILTER SIZE FOR CONTOUR COMPLETIOK-FIT02720
«',F10.3,IX,'DEGREES') FTT02730
C***MODIFY FILTER SIZE SO THAT IT DIVIDES EVENLY INTO 360 DEGREES. FIT02740
NFIL-INT(360./AFIL) FIT02750
C***WRITE MODIFIED ANGULAR FILTER SIZE TO THE DIAGNOSTIC OUTPUT FILE. FTT02760
WRITE(DOOT,126) AFIL FIT02770
126 FORMAT(/,IX,'MODIFIED ANGULAR FILTER SIZE-',F10.3,IX,'DEGREES') FIT02780
1261 CONTINUE . - FIT02790
C***KAKE SURE THAT MAP BOUNDARIES INCLUDE HILL CENTER COORDINATES. FIT02800
XMINl-XHTOP FIT02810
YMIN1-YHTOP FIT02820
XMAX1-XHTOP FIT02830
YMAX1-YHTOP FTT02840
XMIN2-XHTOP FIT02850
YMIN2-YHTOP FIT028CO
XMAX2-XHTOP . FIT02870
YMAX2-YHTOP FIT02880
C***WRTTE THE KILL TOP ELEVATION AND HILL CENTER COORDINATES TO THE ?IT02890
C***DIAGNOSTIC OUTPUT FILE. FIT02900
WRITE(DOUT,130) HTOP,XHTOP,YHTOP FIT02910
130 FORMAT(/,IX,'HILL TOP ELEVATION-',E12.4,/, ' FIT02920
«1X,'HILL CENTER X-COORDINATE-',E12.4,/, . FIT02930
«1X,'HILL CENTER Y-COORDINATE-',E12.4) . FIT02940
C*** • FIT02950
C*** FIT029<0
C SPECIFICATION OF CONTOURS TO BE INPUT FROM THE MASTER FILE USING' FIT02970
C ONE OF 3 METHODS FIT02980
C*** FIT02990
C*** FIT03000
119
-------
C***ASK THE USER TO SPECIFY THE MODE OF CONTOUR SELECTION FROM
C***THE CONTOUR MASTER FILE.
135 WRITE(*,140)
WRITE(*,142)
: 140 FORMAT(//,22X,'SPECIFY CONTOUR SELECTION MODE',/,
422X,'!.) ALL CONTOURS SELECTED',/,
&22X,'2.) SELECT RANGE OF CONTOUR IDs',/,
i22X,'3.) INPUT FILE WITH CONTOUR IDs')
142 FORMAT(/,26X,'CHOICE?(1,2,OR 3) -> *\)
READ(*,'(BN,I3)«,ERR-135) ICMODE
GO TO 150
GO TO 170
GO TO 210
IF(ICMODB.EQ.l)
IF(ICMODE.EQ.2)
IF(ICMODE.EQ.3)
WRITE(*,146)
146 FORMAT(/,IX,'***ERROR***
GO TO 135
FIT03010
FIT03020
FIT03030
FIT03040
FIT03050
FIT03060
FTT03070
FTT03080
FIT03090
FIT03100
FIT03110
FIT03120
FIT03130
FTT03140
MODE SELECTION OUT OF RANGE—TRY AGAIN')FIT03150
FIT03160
1)
C***USE ALL CONTOURS IN THE MASTER FILE(CONTOUR SELECTION MODE
150 WRITE(DOUT,160) MASTER
> 160 FORMAT(/,IX,'ALL CONTOURS IN FILE ',A15,IX,'SELECTED FOR INPUT')
GO TO 300
C***INPUT THE SMALLEST AND LARGEST ID NUMBERS FOR THE GROUP OF
C***CONTOURS(CONTOUR SELECTION MODE NUMBER 2).
I 170 WRITE(*,180)
i 180 FORMAT(/,IX,'INPUT SMALLEST ID NUMBER(1-9999) FOR CONTOUR GROUP ->FIT03240
! * »\) FIT03250
FIT03170
FIT03180
FIT03190
FIT03200
FIT03210
FIT03220
FIT03230
READ(*,'(BN,I4)',ERR~170) ICL
FIT03260
IF(ICL.EQ.O) GO TO 170 FIT03270
1 185 WRITE(*,190) FIT03280
I 190 FORMAT(/,IX,'INPUT LARGEST ID NUMBER(1-9999) FOR CONTOUR GROUP -> FIT03290
*'\) FIT03300
i READ(*,'(BN,I4)',ERR-185) ICU FIT03310
i IF(ICU.EQ.O) GO TO 185 FIT03320
! IF(ICU.GB.ICL) GO TO 195 •• FIT03330
i WRITE(*,191) FIT03340
1 191 FORMAT(/,IX,'***ERROR*** LOWER SERIAL NUMBER GREATER THAN UPPER—FIT03350
! ATRY AGAIN*) FIT03360
: GO TO 170
i 195 CONTINUE
C***WRITE ID RANGE FOR CONTOUR SELECTION TO THE DIAGNOSTIC OUTPUT FILE
I WRITE(DOUT,200) MASTER,ICL,ICU
I 200 FORMAT(/,IX,'CONTOURS SELECTED FROM MASTER FILE ',A15,/,
«1X,'HAVE ID NUMBERS BETWEEN',15,IX,'AND',15)
GO TO 300
C***IHPUT THE NAME OF THE FILE CONTAINING THE CONTOUR ID NUMBERS FOR
C***THE HILL IN QUESTION(CONTOUR SELECTION MODE NUMBER 3).
! 210 WRITE(*,220)
: 220 FORMAT(/,IX,'ENTER CONTOUR ID FILE NAME ->-'\)
I READ(*,'(A)') CON7ILE
I IF(CONFILE.EQ.' *) GO TO 210
C***OPEN CONTOUR ID FILE.
! OPEN(CONIN,FILE-CONFILE,STATUS-'OLD')
C***INPUT ID NUMBERS FROM THE CONTOUR ID FILE.
C***SET COUNTER FOR CONTOUR ID«.
I NdD-1
! 230 CONTINUE
C***READ THE NEXT ID NUMBER.
' READ(CONIN,*,END-270) IDCPK(NCID)
I IfCID-NCID+l
C***CHECK TO SEE IF THE NUMBER OF CONTOURS IS GREATER THAN THE MAXIMUM
C***AMOUNT.
FIT03370
FIT03380
FTT03390
FIT03400
FIT03410
FIT03420
FIT03430
FIT03440
FIT03450
FIT03460
FIT03470
FIT03480
FIT03490
FIT03500
FIT03510
FIT03520
FIT03530
FIT03540
FIT03550
FIT03560
FIT03570
FIT03S80
FIT03590
FIT03600
120
-------
IF(NCID.GT.NCMAX) GO TO 250 FIT03610
GO TO 230 FIT03620
250 WRITE(DOUT,260) NCMAX FIT03630
260 FORMAT(/,IX,•***WARNING***MAXIMUM NUMBER OF CONTOURS(',14,') REAC FIT03640
tHED') FIT03650
C***DETERMINE WHETHER ANY CONTOURS HAVE BEEN REQUESTED. IF NOT, WRITE FIT03660
C***AN ERROR MESSAGE TO BOTH THE DIAGNOSTIC OUTPUT FILE AND THE SCREEN FIT03670
C***AND THEN EXIT THE PROGRAM. FIT03680
270 NCID-NCID-1 FIT03690
IF(NCID.EQ.O) GO TO 1000 FIT03700
WRITE(DOUT,280) NCID,MASTER,IDHILL,HNAME FIT03710
280 FORMAT(/,IX,14,IX,'CONTOURS TO BE SELECTED FROM MASTER FILE ', FIT03720
*A15,/,1X,'FOR HILL',14,'(«,A15,')',//,IX,'IDs REQUESTED:') FIT03730
C***SORT LIST OF CONTOUR IDs IN ASCENDING ORDER. - FIT03740
CALL ISORT(IDCPKfNCID,LPTR) FIT03750
WRITE(DOUT,290) (IDCPK(I),I-1,NCID) FIT03760
290 FORMAT(IX,15) FIT03770
C***CLOSE THE CONTOUR ID FILE. FIT03780
CLOSE(COKIN,STATUS«'KEEP>) FIT03790
300 CONTINUE • FIT03800
C*** FIT03810
C*** FIT03820
C DETERMINE WHETHER A PLOT IS TO BE GENERATED, INPUT PLOT FILE NAME, FIT03830
C AND OPEN THE PLOT FILE. IF PLOT IS REQUESTED, ALSO OPEN A SCRATCH FIT03840
C FILE "PSCRAT". FIT03850
C*** FIT03860
C*** FIT03870
C***ASX WHETHER A PLOT IS TO BE GENERATED. FIRST, INITIALIZE THE PLOT FIT03880
C***FLAG INDICATOR TO CORRESPOND TO A "NO" ANSWER. FIT03890
PFLAG-0 FIT03900
WRITE(*,310) FZT03910
310 FORMAT(/,IX,'PLOT REQUESTED?(Y/N) -> (\) FIT03920
READ(*,'(A)') ANS FIT03930
IF(AHS.EQ.'Y'.OR.ANS.EQ.'y«) PFLAG-1 FIT03940
IF(PFLAG.EQ.O) GO TO 315 ' FIT03950
C***ASX USER TO INPUT THE NAME OF THE PLOT FILE. FIT03960
3101 WRITE(*,311) FIT03970
311 FORMAT(/,IX, 'ENTER PLOT FILE NAME -> «\) .FIT03980
READ(*,'(A)') PFILE • FIT03990
IF(PFILE.EQ.' ') GO TO 3101 FIT04000
C***OPEN THE PLOT FILE AND THE SCRATCH FILE. FIT04010
OPEN (UPL,FILE-PFILE.STATUS-'NEW') FIT04020
OPEN(UPSCR,FILE«'PSCRAT>,STATUS-'NEW') FIT04030
IF(PFLAG.NE.l) GO TO 315 FIT04040
C***WRITE "FITCON" TO THE FIRST RECORD OF THIS PLOT FILE TO INDICATE FIT04050
C***THAT THE PLOT FILE IS BEING GENERATED BY PROGRAM FITCON. FIT04060
WRITE(UPL,3111) . FIT04070
3111 FORMAT('FITCON') FIT04080
C***WRITE THE HILL ID NUMBER AND NAME TO THE PLOT FILE. FIT04090
WRITE (UPL,312) IDHILL,RNAME FIT04100
312 FORHAT(I2,1X,A15) FIT04110
C***WRITE THE HILL CENTER COORDINATES TO THE PLOT FILE. . FIT04120
WRITE(UPL,313) XHTOP,YHTOP FIT04130
313 FORMAT(2E15.4) FIT04140
315 CONTINUE FIT04150
WRZTE(*,316) FIT04160
316 FORMAT(/,IX,'Plaa«a wait...Contour data b«ing procasced',/) FIT04170
C*** FIT04180
C*** . FIT04190
C INPUT AND EDIT CONTOUR DATA. FIT04200
121
-------
C*** FIT04210
C*** FIT04220
C***SET CONTOUR COUNTER. FIT04230
J-l FIT04240
320 CONTINUE FIT04250
C***CHECK WHETHER THE MAXIMUM NUMBER OF CONTOURS HAVE BEEN INPUT. FIT04260
IF(J.OT.NCMAX) GO TO 670 FIT04270
C***INPUT THE ID NUMBER* ELEVATION, NUMBER OF POINTS, AND CONTOUR FIT04280
C***CLOSURE INDICATOR FOR THE NEXT CONTOUR. FIT04290
READ(IN,*,END-700) IDC(J),HCON(J),NPC,CFIAG FTT04300
IF(ICKODE.NE.2) GO TO 340 FIT04310
C***CONTOUR SELECTION MODE 2 FIT04320
C***DETERMINE WHETHER THE CONTOUR ID NUMBER FALLS WITHIN THE BOUNDS FIT04330
C***SPECIFIED BY THE USER. IF NOT, READ DATA FOR ANOTHER CONTOUR FROM FIT04340
C***THE MASTER FILE. FIT04350
IF(IDC(J).LT.ICL.OR.IDC(J).GT.ICU) GO TO 355 FIT04360
GO TO 360 FIT04370
340 IF(ICMODE.NE.3) GO TO 360 FIT04380
C***CONTOUR SELECTION MODE 3 FIT04390
C***DETERM1NE WHETHER THE ID NUMBER FOR THE CONTOUR INPUT FROM THE FIT04400
C***MAST£R FILE MATCHES ONE OF THE SORTED ID NUMBERS INPUT FROM COMPILE.FIT04410
C***IF NOT, READ DATA FOR ANOTHER CONTOUR FROM THE MASTER FILE. FIT04420
DO 350 I-1,NCID FIT04430
C***SINCE IDCPK ARRAY VALUES HAVE BEEN SORTED IN ASCENDING ORDER, THE FIT04440
C***CURRENT ID NUMBER FROM THE MASTER FILE CAN SOMETIMES BE ELIMINATED FIT04450
C***WITHOUT HAVING TO GO THROUGH THE ENTIRE LIST OF IDCPK ARRAY VALUES. FIT04460
IF(IDC(J).LT.IDCPK(I)) GO TO 355 FIT04470
IF(IDC(J).EQ.IDCPK(I)) GO TO 360 FIT04480
350 CONTINUE FIT04490
355 CALL SKIPCN(IH,NPC) FIT04500
GO TO 320 . FIT04510
360 CONTINUE FIT04520
C***CHECK WHJfi'HEK THE CONTOUR ELEVATION IS GREATER THAN THE KILL TOP FIT04530
!C***BLBVATION. IF SO, WRITE AN ERROR MESSAGE AND DISCONTINUE PROCESSING FIT04540
;C***THE CONTOUR. FIT04550
IF(HCON(J).LT.HTOP) GO TO 375 FIT04560
WRITE(*,365) IDC(J) FIT04570
365 FORMAT(/,IX,'Contour ID ',14,IX,'ha« baan rajactad',/,IX, FIT04580
ft'—Saa diagnostic output fila aftar program completion') FIT04590
WRTTE(DOUT,370) IDC(J),HCON(J),HTOP FTT04600
370 FORMAT(/,IX,'***ERROR*** CONTOUR ID',15 ,IX,'DOES NOT RAVE AN ELEFIT04610
tVACTON LESS THEN THE KILL TOP',/,IX,'CONTOUR ELEVATION-»,E12.4, FIT04620
*/,lX,'HILL TOP ELEVATION-',E12.4,/,IX,'CONTOUR WILL NOT BE PROCESSFIT04630
&ED',/)
CALL SKEPCN(IN,HPC)
GO TO 320
C***FIND WHETHER THE CONTOUR HAS AN ELEVATION WHICH IS THE SAME AS A
,C***CONTOUR WHICH HAS BEEN PREVIOUSLY ACCEPTED. IF SO, WRITE AN ERROR
C***MESSAGE AND DISCONTINUE PROCESSING THE CONTOUR. MULTIPLE CONTOURS
C***AT THE SAME ELEVATION MUST BE INPUT AS A SINGLE CONTOUR.
375 IF(J.EQ.l) GO TO 38O
DO 376 JJ-1,JM1
JJK-vTJ •
IT(ABS(HCON(J)-HCON(JJ)).LE.1.0E-15) GO TO 377
376 CONTINUE
GO TO 380
377 WRITE (DOUT, 378) IDC(JJK) ,HCON(J)
378 FORMAT (/, IX, '***ERROR*** PREVIOUSLY ACCEPTED CONTOUR ID1, 15, IX,
ft 'ALSO HAS',/, IX, 'AN ELEVATION OF' , £15. 4, IX, '—CONTOUR REJECTED',
FIT04640
FIT04650
FIT04660
FIT04670
FIT04680
FIT04690
FIT04700
FTT04710
FIT04720
FIT04730
FIT04740
FTT04750
FIT04760
FIT04770
FIT04780
FIT04790
FIT04800
122
-------
&/,lX,'MULTIPLE CONTOURS AT THE SAME ELEVATION MUST BE INPUT AS A SFIT04810
SINGLE CONTOUR') FIT04820
WRITE(*,365) IDC(J) FIT04830
CALL SKIPCN(IN,HPC) . FIT04840
GO TO 320 FIT04850
C***CHEOC WHETHER THE CONTOUR HAS FEWER THAN 3 POINTS. IF SO, WRITE AN FIT04860
C***ERROR MESSAGE AND DISCONTINUE PROCESSING THE CONTOUR. FIT04870
380 IF(NPC.GT.2) GO TO 400 FIT04880
WRITE(*,365) IDC(J) FIT04890
WRITE(DOUT,390) IDC(J),NPC FIT04900
390 FORMAT(/,IX,'***ERROR*** CONTOUR ID', IS,IX,'HAS FEWER THAN 3 POIFIT04910
! WrrS.',/,14X,'CONTOUR HILL NOT BE PROCESSED',/) FZT04920
CALL SKIPCN(IN,NPC) FTT04930
I GO TO 320 FIT04940
C***CHECK WHJgi'EEK THE MAXIMUM NUMBER OF CONTOUR POINTS HAS BEEN EXCEEDEDFIT04950
C***IF SO, WRITE AN ERROR MESSAGE AND DISCONTINUE PROCESSING THE CONTOURFIT04960
400 IF(NPC.LT.NPCMAX) GO TO 420 FTT04970
WRITE(*,36S) IDC(J) FIT04980
WRITE(DOUT,410) IDC(J),NPC,NPCMAX FTT04990
410 FORMAT(/,IX,«***£RROR*** CONTOUR ID',15,IX,'HAS',15,IX,'POINTS.•,FIT05000
*/,14X,'MAXIMUM ALLOWED IS',IS,'. CONTOUR WILL NOT BE PROCESSED.') FITOS010
CALL SKIPCN(IH,HPC)
GO TO 320
C***WRITB THE CONTOUR ELEVATION TO THE DIAGNOSTIC OUTPUT FILE.
420 WRITE(DOUT,425) IDC(J),HCON(J)
425 -FORMAT(/,IX,'CONTOUR ELEVATION FOR CONTOUR ID', 15,IX,'-•,E12.4)
C***INPUT X,Y COORDINATES OF CONTOUR POINTS.
READ(IN,*)
-------
XCONSV(K)-XCON(K) FIT05410
YCONSV(K)-YCON(K) FIT05420
460 CONTINUE FIT05430
IF(MCFLAG.GE.3) GO TO 530 FIT05440
C***P£RFORM EDIT CHECKING FOR A SINGLE CONTOUR. FIT05450
C***FIND THE DISTANCE(DFTOL) FROM THE FIRST TO THE LAST CONTOUR. FIT05460
DFTOL»SQRT((XCON(NPC)-XCOH(l))**2+(YCON(NPC)-YCON(l))**2) FIT05470
C***IF THIS DISTANCE IS EFFECTIVELY ZERO AND THE CONTOUR HAS BEEN FIT05480
C***SPECIFIED AS CLOSED, THEN CONTINUE PROCESSING THE CONTOUR. FIT05490
IF(DFTOL.LT.1.0E-15.AND.CFLAG.EQ.l) GO TO 530 FIT05500
C***IF THIS DISTANCE IS EFFECTIVELY ZERO AND THE CONTOUR HAS BEEN FIT05510
C***SPECIFIED AS OPEN, THEN WRITE A WARNING TO THE DIAGNOSTIC OUTPUT FIT05520
C***FILB AND CONTINUE PROCESSING THE CONTOUR AS IF IT WERE CLOSED. FIT05530
IF(DFTOL.LT.1.0E-15.AND.CFLAG.NE.l) GO TO 510 FTT05540
C***IF THIS DISTANCE IS SIGNIFICANTLY GREATER THAN ZERO AND THE CONTOUR FIT05550
C***HAS BEEN SPECIFIED AS CLOSED, THEN ADD TO THE CONTOUR A FINAL POINT FIT05560
C***WHICH HAS THE SAME COORDINATES AS THE FIRST POINT. IF THE ADDITION FIT05570
C***OF THIS POINT CAUSES THE NUMBER OF CONTOUR POINTS TO EXCEED THE FIT05580
C***HAXIMUM ALLOWABLE, THEN SUBSTITUTE THE FIRST CONTOUR POINT FOR THE FTT05590
C***LAST CONTOUR POINT AND CONTINUE PROCESSING THE CONTOUR AS IF IT WEREFIT05600
C***CLOSED. THE APPROPRIATE WARNINGS ARE WRITTEN TO THE DIAGNOSTIC FIT05610
C***OUTPUT FILE. FIT05620
IF(DFTOL.GB.1.0E-15.AND.CFLAG.EQ.l) GO TO 470 FIT05630
C***IF THIS DISTANCE IS SIGNIFICANTLY GREATER THAN ZERO AND THE CONTOUR FIT05640
C***HAS BEEN SPECIFIED AS OPEN, THEN CALL SUBROUTINE CONCOMP TO ADD FIT05650
C***POINTS TO COMPLETE THE CONTOUR. FIT05660
CALL CONCOMP(XCON,YCON,NPC,NPCMAX,XHTOP,YHTOP,AFIL,NFIL,DOUT) FIT05670
GO TO 330 FIT05680
470 IF(NPC.EQ.NPCHAX) GO TO 490 FTT05690
HPONPC+1 FTT05700
XCON(NPC)-XCON(1) • FTT05710
YCON(NPC)-YCON(1) FTT05720
WRITE(DOUT,480) ' . FTT05730
480 FORMAT(/,IX,'***WARNING***CONTOUR SPECIFIED AS CLOSED WAS FOUND TOFIT05740
t BE OPEN.',/,14X,'ADDED FINAL POINT IS ASSUMED TO BE THE SAME AS TFIT05750
tHE INITIAL POINT.') FIT05760
SO TO 530 FTT05770
490 XCON(NPC)-XCON(1) FTT05780
YCON(NPC)-YCON(1) FTT05790
WRITE(DOUT,500) FIT05800
; 500 FORMAT(/,IX,'***WARNING***CONTOUR SPECIFIED AS CLOSED WAS FOUND TOFIT05810
; t BE OPEN.*,/,14X, 'ADDED FINAL POINT IS ASSUMED TO BE THE SAME AS TFIT05820
; CHE INITIAL POINT',//,IX, '***WARNING***MAXIMUM NUMBER OF CONTOUR POFIT05830
I 4INTS EXCEEDED IN THE CLOSING OPERATION.',/,14X,'FINAL POINT IS REPFIT05840
I 4LACED BY THE INITIAL POINT.') FIT05850
! GO TO 530 FTT05860
| 510 WRITE (DOUT, 520) . FTT05870
| 520 FORMAT(/,IX,'***WARNING***CONTOUR SPECIFIED AS OPEN WAS FOUND TO BFIT05880
! tE CLOSED1) FTT05890
! 530 CONTINUE FIT05900
! C***WRITE THE EDITED NUMBER OF CONTOUR POINTS TO THE DIAGNOSTIC OUTPUT FIT05910
i C***FILE. . FIT05920
! WRITE(DOUT,531) IDC(J),NPC FIT05930
531 FORMAT(/,IX,'MODIFIED NUMBER OF POINTS FOR CONTOUR ID',15,IX,'-•, FTT05940
I *I5) FIT05950
! C***WRITE THE EDITED CONTOUR POINT COORDINATES TO THE DIAGNOSTIC OUTPUT FIT05960
C***FILE. . FIT05970
! WRITE(DOUT,532) IDC(J) FIT05980
i 532 FORMAT(/,IX,'X-Y-COORDINATES(EDITED) FOR CONTOUR ID',15,/) FIT05990
WRITE(DOUT,450) (XCON(K),YCON(K),X-1,NPC) FIT06000
124
-------
c***
c***
C CALCULATE THE AREA AND CENTER OF MASS FOR THE INPUT CONTOUR.
FIT06010
FIT06020
FIT06030
FIT06040
FIT06050
CALL ARCH(XCON,YCON,AR,XC,YC,NPC) FIT06060
AREA-ABS(AR) FIT06070
C***DETERMINE WHETHER THE CALCULATED AREA OF THE CONTOUR IS EFFECTIVELY FIT06080
C***Z£RO. IF SO, WRITE AN ERROR MESSAGE AND DISCONTINUE PROCESSING THE FIT06090
C***CONTOUR. FIT06100
IF(AREA.GT.1.0E-15) GO TO 550 FIT06110
WRITE(*,365) IDC(J) FIT06120
WRITE(DOUT,540) FIT06130
540 FORMAT(/,IX,'AREA FOUND TO BE EFFECTIVELY ZERO—CONTOUR REJECTED1)FITO6140
GO TO 320 FITO6150
550 CONTINUE FIT06160
C***CALCULATE THE MAXIMUM RADIUS OF GYRATION AND THE ASSOCIATED MINOR FIT06170
C***AXIS ORIENTATION FOR THE CONTOUR. FIT06180
CALL SMOMNT(XCON,YCON,AR,NSLOPE,SN,CN,ANGLE,NPC, FITO6190
iXC,YC,RG,RGRAT,ORENT,ISMFLG) FIT06200
C***DETERMINE WHETHER A REAL VALUE FOR THE RADIUS OF GYRATION HAS BEEN FIT06210
C***CALCULATED FOR THE CONTOUR. IF NOT, WRITE AN ERROR MESSAGE AND FIT06220
C***DISCONTINUE PROCESSING THE CONTOUR. FIT06230
IF(ISMFLG.EQ.O) GO TO 555 FIT06240
WRITE(*,365) IDC(J) FIT06250
WRITE(DOUT,551) FIT06260
551 FORMAT(/,IX,'CONTOUR REJECTED—A REAL VALUE FOR THE RADIUS OF GYRAFIT06270
4TION COULD HOT BE*,/,IX,'COMPUTED. THIS CAN OCCUR IF THE CONTOUR IFIT06280
63 VERY TORTUOUS AND TOO FEW POINTS WERE',/,IX,' USED IN ITS DIGITIFIT06290
4ZATION OR IF A VERY TORTUOUS CONTOUR HAS BEEN INPUT AS',/,lX,'INCOFIT06300
tMPLETE EVEN IF A SUFFICIENT NUMBER OF POINTS HAVE BEEN USED IN THEFIT06310
*',/,IX,'DIGITIZATION PROCESS.',//,IX,'SOLUTION—MANUALLY COMPLETE FIT06320
&AND/OR REDIGITIZE THE CONTOUR')
GO TO 320
555 CONTINUE
XCM(J)-XC
i YCM(J)-YC
C***WRITE THE CALCULATED CONTOUR AREA AND CENTROID COORDINATES TO THE
C***DIACNOSTIC OUTPUT FILE.
WRITE(DOUT,5«0) AREA,XCH(J),YCM(J)
; 5«0 FORMAT(/,IX,'CONTOUR AREA-',E12.4,/,
: *1X,'X-COORDINATE OF CONTOUR CENTROID-',E12.4,/,
i ilX,'Y-COORDINATE OF CONTOUR CENTROID-',E12.4)
C***EDIT CHECKS HAVE BEEN COMPLETED. CONTOUR HAS BEEN ACCEPTED FOR
C***PROCESSING.
17 A PLOT HAS BEEN REQUESTED, WRITE THE CONTOUR COORDINATES(BOTH
UNEDITED AND EDITED) TO THE SCRATCH FILE •PSCRAT" AND UPDATE THE
PLOT BOUNDARIES TO REFLECT THE BOUNDARIES OF THE NEWLY INPUT
CONTOUR.
1C***
c***
c***
IT(PFLAG.EQ.O) GO TO 575
WRITE(UPSCR,570) NPCSV,HCON(J)
570 FORMAT(110,£15.4)
DO 572 K-l,NPCSV
WRITE(UPSCR,571) XCONSV(X),YCONSV(K)
571 FORMAT(2E15.4)
IF(XCONSV(X).GT.XMAX1) XMAX1-XCONSV(K)
FIT06330
FIT06344
FIT06350
FIT0636e
FIT06370
FTT06380
FIT06390
FITO6400
FITO6410
FIT06420
FIT06430
FIT06440
FIT06450
FTT06460
FIT06470
FIT06480
FIT06490
FIT06500
FIT06510
FIT06520
FIT06530
FIT06540
FIT06550
FTT06560
FIT06570
FIT06580
FIT06590
FIT06600
125
-------
XMIN1-XCONSV(K)
YMAXl-YCONSV(K)
YMINl-YCONSV(K)
IF(XCONSV(K).LT.XMIN1)
IF(YCONSV(K).GT.YMAX1)
IF(YCONSV(K).LT.YMIN1)
572 CONTINUE
WRITE(UPSCR,570) NPC,HCON(J)
DO 574 K-1,NPC
WRITE(UPSCR,571) XCON(K),YCON(K)
IF(XCON(K).GT.XMAX2) XMAX2-XCON(K)
.LT.XHIN2)
.GT.YMAX2)
.LT.YMIN2)
IF(XCON(K)
IF(YCON(K)
IF(YCON(K)
CONTIHUE
XHIN2-XCON(K)
YMAX2-YCON(K)
YKtN2-YCON(K)
574
575 CONTIHUE
C***
c***
C COMPOTE THE PARAMETERS FOR THE ELLIPTICAL REPRESENTATION OF THE
C CONTOUR.
C***
c***
OREN(J)-ORENT
C***CALCULATE THE SEMI-MAJOR AXIS LENGTH FOR THE EQUIVALENT ELLIPSE
C***USING THE RELATIONSHIP, FOR AN ACTUAL ELLIPSE, BETWEEN THE
C***SEMI-MAJOR AXIS LENGTH AND THE RADIUS OF GYRATION ABOUT AN AXIS
C***WHICH COINCIDES WITH THE SEMI-MINOR AXIS OF THE ELLIPSE.
A(J)-2.*RG
C***CALCULATE THE SEMI-MINOR AXIS LENGTH FOR THE EQUIVALENT ELLIPSE
C***USING THE FORMULA FOR THE AREA OF AN ELLIPSE AND THE PREVIOUSLY
C***DETERMINED VALUE FOR THE SEMI-MAJOR AXIS LENGTH.
B(J)-AREA/(PI*A(J))
C***DETERMINE WHETHER THE CONTOUR SHOULD BE CONSIDERED CIRCULAR
C***FXRST TEST FOR CIRCULAR CONTOUR—CALCULATED SEMI-MINOR AXIS
C***LENGTH GREATER THAN OR EQUAL TO SEMI-MAJOR AXIS LENGTH.
IF(A(J).GT.B(J)) GO TO 390
WRITE(DOUT,580)
980 FORMAT(/,IX,'CALCULATED ELLIPSE SEMI-MINOR AXIS LENGTH WAS FOUND',
t' TO BE GREATER THAN*,/,IX,'OR EQUAL TO THE CALCULATED SEMI-MAJOR'
*,' AXIS LENGTH—CONTOUR ASSUMED TO BE CIRCULAR')
GO TO 610
C***SECOND TEST FOR CIRCULAR CONTOUR—DETERMINE WHETHER THE RELATIVE
C***DIFFERENCE BETWEEN THE MAXIMUM AND MINIMUM RADII OF GYRATION FOR
C***THE CONTOUR IS LESS THAN 1 PERCENT.
990 IF(RGRAT.GT.O.Ol) GO TO 620
WRITE(DOUT,600)
600 FORMAT(/,IX,'THE RELATIVE DIFFERENCE BETWEEN THE MAXIMUM AND',
*' MINIMUM RADII OF GYRATION',/,IX,'FOR THE CONTOUR IS LESS THAN',
t* 1 PERCENT—CONTOUR ASSUMED TO BE CIRCULAR')
C***SET BOTH THE SEMI-MAJOR AND SEMI-MINOR AXIS LENGTHS EQUAL TO THE
C***RADIUS OF A CIRCLE WITH AREA EQUAL TO AREA.
610 RAD-SQRT(AREA/PI)
C***THE ECCENTRICITY OF A CIRCLE IS ZERO.
ECC(J)-0.
A(J)-RAD
B(J)«RAD
GO TO 630
C***CALCULATE THE ECCENTRICITY OF THE ELLIPSE REPRESENTING THE CONTOUR.
620 ECC(J)-SQRT(A(J)**2-B(J)**2)/A(J)
C***WRITE ELLIPSE FIT PARAMETERS TO THE DIAGNOSTIC OUTPUT FILE.
630 WRITE(DOUT,640) IDC(J)
640 FORMAT(/,IX,'ELLIPSE PARAMETERS FOR CONTOUR ID',I5,/)
WRITE(DOUT,650) A(J),B(J),ECC(J),OREN(J)
FIT06610
FIT06620
FIT06630
FIT06640
FIT06650
FIT06660
FIT06670
FITO«680
FIT06690
FIT06700
FIT06710
FIT06720
FIT06730
FTT06740
FIT06750
FIT06760
FIT06770
FIT06780
FIT06790
FIT06800
FIT06810
FIT06820
FIT06830
FIT06840
FIT06850
FIT06860
FIT06870
FIT06880
FIT06890
FIT06900
FIT06910
FIT06920
FIT06930
FIT06940
FIT06950
FIT06960
FIT06970
FIT06980
FIT06990
FIT07000
FIT07010
FIT07020
FIT07030
FIT07040
FIT07050
FIT07060
FIT07070
FIT07080
FIT07090
FIT07100
FIT07110
FIT07120
FIT07130
FIT07140
FIT07150
FIT07160
FIT07170
FIT07180
FIT07190
FIT07200
126
-------
650 FORMAT(IX,'SEMI-MAJOR AXIS LENGTH-',E12.4,/, FIT07210
«1X,'SEMI-MINOR AXIS LENGTH-',E12.4,/, FIT07220
*1X,'ELLIPSE ECCENTRICITY-',E12.4,/, FIT07230
«1X,'ORIENTATION OF SEMI-MINOR AXIS WITH RESPECT TO THE1, FIT07240
«/,IX,'POSITIVE X-AXIS-',F«.2,IX,•DEGREES•) FIT07250
C***UPDATE THE CONTOUR COUNTER AND READ DATA FOR A NEW CONTOUR FROM THE FIT07260
C***MAST£R FILE. FIT07270
HRITE(*,660) IDC(J) FTT07280
660 FORMAT(/,IX,'Contour ID ',14,IX,'has been accepted') FIT07290
J-J+1 FIT07300
•• GO TO 320 'FIT07310
670 -WRITE(DOUT,260) FIT07320
C***END OF CONTOUR MASTER FILE REACHED • FIT07330
! 700 MOJ-1 FIT07340
C***CLOSE THE MASTER FILE. FIT07350
CLOSE(IN,STATUS-'KEEP') FIT07360
C***IF THE CONTOUR ID NUMBERS(FOR CONTOUR SELECTION FROM THE MASTER FIT07370
C***FILE) WERE INPUT FROM CONFILE, CHECK WHETHER THE NUMBER OF CONTOURS FIT07380
C***REQUESTED MATCHES THE NUMBER ACTUALLY SELECTED FROM THE MASTER FILE.FIT07390
C***IF NOT, WRITE A WARNING MESSAGE Td THE DIAGNOSTIC OUTPUT FILE. FTT07400
IF(ICMODE.EQ.3.AND.NC.NE.NCID) WRITE(DOUT,710) ' FIT07410
710 FORMAT(/,IX,•***WARNING***NUMBER OF CONTOURS SELECTED FROM THE1, FIT07420
: «' MASTER FILE DOES NOT',/,14X,'MATCH THE NUMBER REQUESTED') FIT07430
C***CHECK WHETHER ANY CONTOURS HAVE BEEN SELECTED FROM THE MASTER FILE. FIT07440
C***IF NOT, WRITE AN ERROR MESSAGE BOTH TO THE DIAGNOSTIC OUTPUT FILE FIT07450
C***AND THE SCREEN AND THEN EXIT THE PROGRAM. FIT07460
I IF(NC.EQ.O) GO TO 1010 FIT07470
C*** . FIT07480
C*** FTT07490
C***WRITE THE OUTPUT FILES FOR SUBSEQUENT PROCESSING BY THE PLOT PROGRAMFIT07500
C***AND THE CRITICAL HEIGHT ANALYSIS PROGRAM(HCRIT). . FIT07510
'C*** FIT07520
C*** . FIT07530
C***SORT THE ID NUMBERS FOR THE CONTOURS WHICH WERE FINALLY SELECTED. FIT07540
CALL ISORT(IDC,NC,LPTR) FIT07550
C***CHECK WHETHER PLOT HAS BEEN REQUESTED. IF SO, WRITE TO THE PLOT FIT07560
C***FILE THE INFORMATION NECESSARY TO SUBSEQUENTLY PLOT THE INPUT FIT07570
C***DIGITIZED CONTOURS. FIT07580
1 IF(PFLAG.EQ.O) GO TO 770 FIT07590
C***REWIND THE SCRATCH FILE. FIT07600
REWIND UPSCR FIT07610
C***WRITE THE NUMBER OF*CONTOURS TO THE PLOT FILE. FIT07620
WRITE(UPL,720} NC . FIT07630
720 FORMAT(110) FIT07640
C***WRITE THE SORTED CONTOUR ID NUMBERS TO THE PLOT FILE. FIT07650
C***NOTE: THE CONTOUR IDs ARE SORTED ONLY FOR SUBSEQUENT ID CHECKS IN FIT07660
C***THE PLOT PROGRAM. THE DIGITIZED CONTOURS INPUT TO THE PLOT PROGRAM FIT07670
C***DO NOT RAVE TO BE SORTED. FIT07680
WRITE(UPL, 730) (IDC(J),J-1,NC) FIT07690
730 FORMAT(IIO) FIT07700
C***WRITE THE PLOT BOUNDARY LIMITS FOR BOTH UNEDITED AND EDITED FIT07710
C***CONTOURS TO THE PLOT FILE. . FIT07720
WRITE(UPL,740) XMIN1,XMAX1,YMIN1,YMAX1 FIT07730
740 FORMAT(4E15.4) FTT07740
WRITE(UPL,740) XMIN2,XMAX2,YMIN2,YMAX2 FIT07750
C***TRANSFER THE DIGITIZED CONTOUR COORDINATES FROM THE SCRATCH FILE FIT07760
C***TO THE PLOT FILE. FIT07770
NCT2-2*NC FIT07780
DO 760 J-1,NCT2 FIT07790
READ(UPSCR,570) NPC.HCONT • FIT07800
127
-------
WRITE (UK,, 570) HPC,HCONT FIT07810
DO 750 K-1,NPC FIT07820
READ (UPSCR ,-571) XCOH(K),YCON(K) FIT07830
WRITE (UPL, 571) XCOK(K),YCOH(K) PTT07840
750 CONTINUE FIT07850
760 CONTINUE ' FIT07860
C***CLOSE AND DELETE THE SCRATCH- FILE.' nT07870
CLOSE(UPSCR,STATUS-•DELETE•) FIT07 880
C***OP£N THE OUTPUT FILE FOR THE CRITICAL HEIGHT ANALYSIS PROGRAM. FIT07890
770 CONTINUE FIT07900
775 WRITE(*,780) FIT07910
780 FORMAT(/,IX,'ENTER FILE NAME FOR FITTED CONTOUR OUTPUT -> f\) FIT07920
READ(*,f(A)1) COUTFILE FIT07930
IF(COUTFILB.EQ.' ') GO TO 775 FIT07940
OPEN(GOUT,FILE-CODTFILE,STATUS-'NEW') FIT07950
C***WRITE THE HILL ID NUMBER AND NAME TO THE FITTED CONTOUR OUTPUT FIT07960
C***FILE. FIT07970
WRITE(COUT,312) IDHILL,HNAME FIT07980
C***WRITE THE ACTUAL HILL TOP ELEVATION TO THE FITTED CONTOUR OUTPUT FIT07990
C***FILE. FIT08000
WRITE(COUT,790) HTOP FIT08010
790 FORMAT(£15.4) FIT08020
C***WRITE THE NUMBER OF CONTOURS TO THE FITTED CONTOUR OUTPUT FILE. FIT08030
WRITE(COUT,720) NC FIT08040
C***WRITE THE SORTED CONTOUR IDs TO THE FITTED CONTOUR OUTPUT FILE.. FIT08050
C***NOTB: CONTOUR IDs ARE SORTED ONLY FOR SUBSEQUENT ID CHECKS IN FIT08060
C***THE PLOT PROGRAM. FITTED CONTOUR PARAMETERS DO NOT HAVE TO BE FIT08070
C***SORTED FOR INPUT TO THE CRITICAL HEIGHT ANALYSIS PROGRAM. FIT08080
WRITE(COUT,730) (IDC(J),J-1,NC) FIT08090
C***WRITE THE CONTOUR FIT PARAMETERS TO THE FITTED CONTOUR OUTPUT FIT08100
C***FILE. FIT08110
DO 810 J-1,NC • FIT08120
WRITE(COUT,800) HCON(J) ,XCM(J) ,YCH(J) ,A(J) ,B(J) ,ECC(J) ,OREN(J) FIT08130
800 FORMAT(7E15.4) FIT08140
810 CONTINUE . . - FIT08150
IF(PFLAG.EQ.O) GO TO 840 FTT08160
C***WRITE THE CONTOUR FIT PARAMETERS TO THE PLOT FILE. . FIT08170
DO 830 J-1,NC FIT08180
WRITE (UPL,820) XCM(J),YCH(J)/A(J),B(J),OREN(J) FIT08190
820 FORMAT(5E15.4) FIT08200
830 CONTINUE FIT08210
840 CONTINUE FIT08220
C***ANALYSIS COMPLETED—EXIT PROGRAM. FIT08230
GO TO 2000 FIT08240
1000 WRITE(DOUT,1005) FIT08250
1005 FORMAT(/,IX,'***ERROR*** NO CONTOURS WERE REQUESTED—EXIT PROGRAMFIT08260
ft1) . FIT08270
WRITE(*,1005) FIT08280
GO TO 2000 FIT08290
1010 WRITE(DOUT,1015) FIT08300
1015 FORMAT(/,IX,•***ERROR*** NO CONTOURS SELECTED FROM MASTER FILE—EFIT08310
ftXIT PROGRAM') • . FIT08320
WRITE(*,1015)
C***DELETE SCRATCH FILE AND PLOT FILE.
CLOSE(UPSCR,STATUS*'DELETE')
CLOSE(UPL,STATUS-'DELETE')
2000 CONTINUE
STOP
END
FIT08330
FIT08340
FIT08350
FIT08360
FIT08370
FIT08380
FIT08390
128
-------
; SUBROUTINE AHCM(XCON,YCON,AR,XC,YC,NPC)
C***SUBROUTINE TO CALCULATE THE AREA AND CENTROID X-Y COORDINATES
C***FOR AN INPUT CONTOUR
DIMENSION- XCON(1),YCON(1)
AR-0.
XOO.
YC-0.
NPCMl-NPC-1
DO 100 K-1,NPCM1
AR-AR+(YCON(K+l)+YCON(K))*(XCON(K+l)-XCON(K))/2.
XOXC+0. 5* (XCON(K+l) *YCON(K) -XCON(K) *YCON(K+l)) *
«(XCON(K+1)+XCON(K) ) + (YCON (X+l)- YCON (K)) *
4(XCON(K+1)**2+XCON(K)*XCON(K+1)+XCON(K)**2)/3.
YC-YC+0.5* (YCON(K+1) *XCON(K) -YCON(K) *XCON(K+1)) *
«(YCON(K+1)+YCON(K))+(XCON(K+1)-XCON(K))*
«(YCON(K+1) **2+YCON(K) *YCON(K+1)+YCON(K) **2)/3.
XOO CONTINUE
C***CLOSE CONTOUR FOR PURPOSES OF CALCULATING THE AREA AND CENTROID.
C***THIS IS REQUIRED FOR USE OF THE SUBROUTINE BY SUBROUTINE CONCOMP,
C***THE CONTOUR COMPLETION SUBROUTINE.
AR-AR*(YCON(1)+YCON(NPC))*(XCON(1)-XCON(NPC))/2.
XOXC+0 . 5* (XCON (1) *YCON (NPC) -XCON (NPC) * YCON (1)) *
&(XCON(1)+XCON(NPC))+(YCON(1)-YCON(NPC))*
« (XCON(l) **2+XCON(NPC) *XCON(1) -t-XCON(NPC) **2)/3.
YC>YC+0.5*(YCON(1)*XCON(NPC)-YCON(NPC)*XCON(1))*
4(YCON(l)-l-YCON(NPC))-l-(XCON(l)-XCON(NPC))*
C**
«(YCON(1)**2+YCON(NPC)*YCON(1)+YCON(NPC)**2)/3.
'CHECK FOR ZERO AREA CONTOUR
IF(ABS(AR).LT.1.0E-15) RETURN
XOXC/AR
YC—YC/AR
RETURN
END
ARC00010
ARC00020
ARC00030
ARC00040
ARC00050
ARC00060
ARC00070
ARC00080
ARC00090
ARC00100
ARC00110
ARC00120
ARC00130
ARC00140
ARC00150
ARC00160
ARC00170
ARC00180
ARC00190
ARC00200
ARC00210
ARC00220
ARC00230
ARC00240
ARC00250
ARC00260
ARC00270
ARC00280
ARC00290
ARC00300
ARC00310
ARC00320
ARC00330
129
-------
SUBROUTINE CONCOMP(XCON,YCON,NPC,NPCMAX,XHTOP,YHTOP,AFIL,NFIL, CCP00010
6DOUT) . CCP00020
C***THIS SUBROUTINE COMPLETES A CONTOUR WHICH HAS BEEN INPUT FROM THE CCP00030
C***CONTOUR MASTER FILE AS AN INCOMPLETE CONTOUR. THE FIRST STEP IN THISCCP00040
C* "COMPLETION PROCESS IS THE ELIMINATION OF THOSE POINTS WHICH LIE IN CCP00050
C***THE SAME SECTOR AS (1)AN ACTUAL CONTOUR POINT WHICH IS CLOSER TO CCP00060
C***THE HILL CENTER OR (2)A SEGMENT OF A LINE CONNECTING ADJACENT POINTSCCP00070
C***WHICH IS CONTAINED WITHIN THE SECTOR AND WHOSE APPROXIMATE MIDPOINT CCP00080
C***IS CLOSER TO THE HILL CENTER THAN THE POINT IN QUESTION.
C***
ic***
C GLOSSARY OF TERMS
C***
c***
C
C
C
C
C
C
C
C
C
C
C
C
C
-------
DO 1 ISEO1,NTIL CCP00670
DXSTM(XSEC)-0. CCP00680
IR(ISEC)-0 - CCP00690
1 CONTINUE CCP00700
NCOUNT-0 CCP00710
N7ILM-FLOAT(NTIL)/2.+0.500001 CCP00720
XP-XCON(l) CCP00730
YP-YCON(l) CCP00740
C***CALCULATE THE SECTOR AND DISTANCE FROM THE HILL CENTER FOR THE FIRSTCCP00750
C***CONTOUR POINT. CCP00760
CALL VECTOR(XHTOP,YHTOP,XP,YP,ANGLE,DX,DY) CCP00770
ISOLD-ANGLE/AFIL CCP00780
IF(ISOLD.LT.l) ISOLD-1 CCP00790
IF(ISOLD.GT.NFIL) ISOLD-NFIL CCP00800
DOLD-SQRT((XP-XHTOP)**2+(YP-YHTOP)**2) CCP00810
C***CHOOSE THE CLOSEST POINT TO THE HILL CENTER LOCATION FOR EACH CCP00820
C***SECTOR OF ANGULAR WIDTH AFIL. CCP00830
DO 3 K-1,NPC CCP00840
XP-XCON(K) CCP00850
YP-YCON(K) CCP00860
DIST-SQRT((XP-XHTOP)**2+(YP-YHTOP)**2) CCP00870
CALL VECTOR(XHTOP,YHTOP,XP,YP,ANGLE,DX,DY) CCP00880
ISEC-ANGLE/AFIL CCP00890
IF(ISEC.LT.l) ISE01 CCP00900
IF(ISEC.GT.NFIL) ISEONFIL CCP00910
C***DETERMINE WHETHER A CONTOUR POINT OR SEGMENT HAS ALREADY APPEARED INCCP00920
C***THIS ANGULAR SECTOR. CCP00930
IF(IR(ISEC).NE.O) GO TO 2 CCP00940
NCOUNT-NCOUNT+1 . CCP00950
C***ACCEPT THE POINT(XCON(X),YCON(X)) AND INITIALIZE THE ARRAYS IR AND CCP00960
C***DISTM. CCP00970
XCONS(NCOUNT)-XP CCP00980
YCONS(NCOUNT)-YP CCP00990
IR(ISEC)-NCOONT CCP01000
DISTM(ISEC)-SQRT((XP-XHTOP)**2+(YP-YHTOP)**2) CCP01010
GO TO 1000 CCP01020
C***D£TERMINE WHETHER THE DISTANCE FROM THE HILL CENTER TO THE POINT IS CCP01030
C***LESS THAN THE CURRENT MINIMUM DISTANCE FOR THIS SECTOR. CCP01040
2 CONTINUE CCP01050
IF(DIST.GE.DISTM(ISEC)) GO TO 1000 CCP01060
C***REINITIALIZE DISTM(ISEC) TO CORRESPOND TO THE DISTANCE FROM THE CCP01070
C«**HILL CENTER FOR THE CONTOUR POINT IN QUESTION. CCP01080
DISTM(ISEC)-DIST CCP01090
C***TEMPORARILY SAVE THE PREVIOUS VALUE OF IR(SEC). CCP01100
IROLD-IR(ISEC) . CCP01110
IF(IROLD.EQ.9999) GO TO 201 CCP01120
C***FLAG THE X-COORDINATB OF THE PREVIOUSLY CLOSEST CONTOUR POINT CCP01130
C***(IROLD) FOR LATER ELIMINATION OF THE POINT. CCP01140
XCONS(IROLD)-1.0E+13 CCP01150
201 NCOUNT-NCOUNT+1 CCP01160
C***REINITIALIZE THE IR ARRAY TO CORRESPOND TO THE NUMBER OF THE CONTOURCCP01170
C***POINT IN QUESTION. • CCP01180
IR(ISEC)-NCOUNT CCP01190
C***ACCEPT THE CONTOUR POINT NCOUNT. CCP01200
XCONS(NCOUNT)-XP CCPO1210
YCONS(NCOUNT)-YP CCPO1220
C***HANDLE SECTORS BETWEEN THOSE SECTORS OCCUPIED BY THE CURRENT AND CCP01230
C***PREVIOUS CONTOUR POINTS. CCPO1240
C***DETERMINE HOW MANY SECTORS RAVE BEEN CROSSED. IF MORE THAN ONE HAS CCPO1250
C***BEEN CROSSED, THEN DEAL WITH "PSEUDOPOINTS" WHICH OCCUPY SECTORS CCP01260
C***BETWEEN THE CURRENT AND PREVIOUS CONTOUR POINTS. CCP01270
1000 ITEST-IABS(ISEC-ISOLD) CCPO1280
C***DETERMINE WHETHER MORE THAN ONE SECTOR HAS BEEN CROSSED. . CCP01290
IF(ITEST.LE.l.OR.ITEST.EQ.NFIL-l) GO TO 14QO CCPO1300
C***FOUR CASES: CCP01310
C***(l) ISEOISOLD; ISEC-ISOLO-MFILM CCP01320
131
-------
C***(2) ISEOISOUD; ISEC-ISOLDISEC; ISOLD-ISEO-NFILM CCP01340
C***(4) ISOLD>ISEC; ISOLD-ISEC
-------
IF(IR(I).EQ.9999) GO TO 1202 CCP01990
IROLD-IR(I) CCP02000
XCONS(IROLD)-1.0E+15 . CCP02010
1201 HI (I)-9999 CCP02020
1202 DISTM(I)-DTEST CCP02030
COUNT-COUNT+1. CCP02040
1210 CONTINUE CCP02050
GO TO 140O CCP02060
C***CASE II • CCP02070
1300 OIF-FLOAT(NFIL-(ISEC-ISOLD)) CCP02080
COUNT-1. • CCP02090
I C***LOOP MUST BE BROKEN INTO 2 PARTS. CCP02100
C***PART ONE CCP02110
DO 13SO I-ISOLD-1,1,-1 CCP02120
DTEST»DOLD+(COONT/DIF)*(DIST-DOLD) CCP02130
IP(DTEST.GT.DISTH(I).AND.IR(I).NE.O) GOTO 1350 CCP02140
IF(IR(I).EQ.O) GO TO 1311 CCP02150
IF(IR(I).EQ.9999) GO TO 1312 CCP02160
IROLD-IR(I) CCP02170
i XCONS(IROLD)-1.0E+1S CCP02180
1311 HI (I)-9999 CCP02190
i 1312 BISTM(I)-DTEST CCP02200
COUNT-COUNT+1. CCP02210
1350 CONTINUE CCP02220
:c***PART TWO CCP02230
DO 1360 I-NFIL,ISEC+1,-1 CCP02240
DTEST-DOLD+(COUNT/DIF)*(DIST-DOLD) CCP02250
I IF(DTEST.GT.DISTH(I).AND.IR(I).NE.O) GO TO 1360 CCP02260
IF(IR(I).EQ.O) GOTO 1351 CCP02270
IF(IR(I).EQ.9999) GO TO 1352 CCP02280
: IROLD-IR(I) CCP02290
XCONS(IROLD)-1.0E+1S CCP02300
j 1351 IR(I)-9999 CCF02310
! 1352 DISTH(I)-DTEST CCP02320
I COUNT-COUNT+1. CCP02330
' 1360 CONTINUE CCP02340
' C***SAVE THE SECTOR NUMBER AND DISTANCE FOR COMPARISON WITH THE NEXT CCP02350
C***POINT. CCP02360
1400 ISOLD-ISEC . CCP02370
DOLD-DIST CCP02380
3 CONTINUE * CCP02390
NPC-1 CCP02400
DO 4 K-1,NCOONT CCP02410
IF(XCONS(K).GT.1.0E+14) GO TO 4 ' CCP02420
XCON(NPC)-XCONS(K) CCP02430
TCON(NPC)-TCONS(K) CCP02440
NPC-HPC+l CCP02450
4 CONTINUE CCP02460
; NPOHPC-1 CCP02470
! 45 CONTINUE CCP02480
\ C***CKLL SUBROUTINE ARCM TO DETERMINE THE AREA OF THE INCOMPLETE CCP02490
: C***CONTOUR. IF THE AREA IS NEGATIVE, THEN THE CONTOUR POINTS HAVE CCP02500
C***BEEN INPUT IN A COUNTERCLOCKWISE SENSE. IF THE AREA IS POSITIVE, CCP02510
O**THEN THE CONTOUR POINTS HAVE BEEN INPUT IN A CLOCKWISE SENSE. CCP02520
C***THIS INFORMATION IS REQUIRED BY THE CONTOUR COMPLETION ALGORITHM. CCP02530
C***THE X AND Y COORDINATES OF THE INCOMPLETE CONTOUR CENTER OF CCP02540
I C***MASS(XCM,YCM) ARE NOT USED BY THE CONTOUR COMPLETION ALGORITHM. CCP02550
! C***FIRST ADD THE POINT (XHTOP,YHTOP) TO THE CONTOUR ONLY FOR THE CCP02560
C***PURPOSE OF THIS DIRECTION DETERMINATION. CCP02570
! METH-0 CCP02580
XREF-XHTOP CCP02590
YREF-YHTOP CCP02600
NPCPl-HPC-t-1 CCP02610
C***CHECK WHETHER CONTOUR COMPLETION WILL CAUSE THE NUMBER OF CONTOUR CCP02620
:O**POINTS TO EXCEED THE MAXIMUM. IF SO, SET THE COORDINATES OF THE CCP02630
! C***FINAL POINT EQUAL TO THOSE OF THE INITIAL POINT AND PRINT A WARNING CCP02640
133
-------
C***MESSAGE. CCP02650
IF(NPCPl.LT.NPCMAX) GO TO 5 CCP02660
XCON(NPC)-XCON(1) CCP02670
YCON(NPC)-YCON(1) • CCP02680
WRITE(DOUT,20) NPCMAX CCP02690
RETURN CCP02700
5 XCON(NPCP1)-XHTOP CCP02710
YCON(NPCP1)-YHTOP CCP02720
CALL ARCM(XCON,YCON,AREA,XCMfYCM,MPCPl) CCP02730
6 XP-XCON(l) CCP02740
YP-YCON(l) CCP02750
C***FIND THE HEADING AND X,Y COMPONENTS OF THE VECTOR FROM THE HILL CCP02760
C***TOP X,Y POINT TO THE FIRST CONTOUR POINT. CCP02770
CALL VECTOR(XREF,YREF,XP,YP,ANGLE,DX,DY) CCP02780
IF(AREA.LT.O.) ANG2-ANGLE CCP02790
IF(AREA.GE.O.) ANG1-ANGLE CCP02800
XP-XCON(NPC) CCP02810
YP-YCON(NPC) CCP02820
C***FIND THE HEADING AND X,Y COMPONENTS OF THE VECTOR FROM THE HILL CCP02830
C***TOP X,Y POINT TO THE LAST CONTOUR POINT. CCP02840
CALL VECTOR(XREF,YREF,XP,YP,ANGLE,DX,DY) CCP02850
IF(AREA.LT.O.) ANG1-ANGLE CCP02860
IF(AREA.GE.O.) ANG2-ANGLE CCP02870
IF(METH.EQ.l) GO TO 7 CCP02880
ADIF-ANG2-ANG1 CCP02890
IF(ADIF.LT.O.) ADIF-360.+ADIF CCP02900
C***IF THE ANGULAR DIFFERENCE BETWEEN THE VECTORS IS LESS THAN CCP02910
C***90 DEGREES, USE THE CENTROID OF THE CONTOUR FOR THE REFLECTION CCP02920
C***POINT INSTEAD OF THE HILL CENTER. CCP02930
IF(ADIF.GT.90.) GO TO 7 CCP02940
CALL ARCM(XCON,YCON,AREA,XCM,YCM,NPC) CCP02950
XREF-XCM CCP02960
YREF-YCM CCP02970
METH-1 CCP02980
GO TO 6 CCP02990
7 CONTINUE ' CCP03000
C***SAVE THE NUMBER OF ORIGINAL CONTOUR POINTS. CCP03010
NPCO-NPC CCP03020
C***» THE CASE OF POSITIVE(NEGATIVE) CONTOUR AREA, DETERMINE, FOR EACH CCP03030
C***CONTOUR POINT, WHETHER THE HEADING OF THE VECTOR FROM THE CONTOUR CCP03040
C***POINT TO THE HILL TOP X,Y POINT LIES BETWEEN THE HEADINGS OF THE CCP03050
C***VECTORS FROM THE HILL TOP X,Y POINT TO THE FIRST(LAST) CONTOUR POINTCCP03060
•C***AND FROM THE HILL TOP X,Y POINT TO THE LAST(FIRST) CONTOUR POINT. CCP03070
C***IF THIS IS SO, THEN ASSIGN AN ADDITIONAL CONTOUR POINT AT THE CCP03080
C**«IERMINATION OF THE VECTOR HAVING A HEADING EQUAL TO THAT OF THE CCP03090
C***VECTOR FROM THE ORIGINAL CONTOUR POINT TO THE HILL TOP X,Y POINT CCP03100
C***AND HAVING A LENGTH EQUAL TO TWICE THE LENGTH OF THIS VECTOR. IF CCP03110
.C***THE ADDITION OF A CONTOUR POINT WOULD CAUSE THE MAXIMUM NUMBER OF CCP03120
C***CONTOUR POINTS TO BE EQUALED, THEN THE COORDINATES OF THIS CONTOUR CCP03130
C***POINT ARE SET EQUAL TO THE COORDINATES OF THE FIRST CONTOUR POINT CCP03140
C***AND THE CONTOUR COMPLETION PROCESS IS HALTED. CCP03150
DO 100 K-1,NPCO ' CCP03160
XP-XCON(K) CCP03170
YP-YCON(K) CCP03180
CALL VECTOR(XP,YP,XREF,YREF,ANGLE,DX,DY) CCP03190
IF(ANG1.GT.ANG2) GO TO 40 CCP03200
IF(ANGLE.GT.ANG1.AND.ANGLE.LT.ANG2) GO TO 10 CCP03210
GO TO 100 CCP03220
10 NPC-NPC+1 CCP03230
IF(NPC.LT.NPCKAX) GO TO 30 CCP03240
XCON(NPC)-XCON(1J CCP03250
YCON(NPC)-YCON(1) CCP03260
WRITE(DOUT,20) NPCMAX CCP03270
20 FORMAT(/,IX,'***WARNING***CONTOUR COMPLETION HALTED DUE TO EXCEEDACCP03280
&NCE OF1,/,IX,'MAXIMUM NUMBERC,13,IX,') OF CONTOUR POINTS1,/, CCP03290
SIX,'THE FINAL CONTOUR POINT WILL HAVE COORDINATES EQUAL TO THOSE OCCP03300
134
-------
4F THE IKITIAL POINT1) CCP03310
RETURN CCP03320
30 XCON(NPC)-XREF+DX . CCP03330
I YCON(NPC)-YREF+DY CCP03340
I GO TO 100 CCP03350
: 40 IF(ANGLE.LT.ANG1.AND.ANGLE.GT.ANG2) GO TO 100 CCP03360
NPONPOH CCP03370
IF(NPC.LT.NPCKAX) GO TO 50 CCP03380
XCON(NPC)-XCON(1) CCP03390
YCON(NPC)-YCON(1) CCP03400
WRITE(DOOT,20) NPCMAX CCP03410
RETURN CCP03420
50 XCON(NPC)-XREF+DX CCP03430
YCON(NPC)-YREF+DY CCP03440
100 CONTINUE CCP03450
C***CLOSE OUT THE CONTOUR BY ADDING A FINAL POINT WITH COORDINATES CCP03460
C***EQUAL TO THOSE OF THE INITIAL POINT. CCP03470
NPC-NPC+1 CCP03480
XCON(NPC)-XCON(1) CCP03490
YCON(NPC)«YCON(1) CCP03500
RETURN CCP03510
END CCP03520
135
-------
i SUBROUTINE ISORT(LIST,NDL,LPTR)
C***MERGE EXCHANGE SORT
£***NUMBER OF COMPARISONS»N*LOG(N)/LOG(2)
C***LIST-ARRAY TO BE SORTED
C***NDL-NUMBER OF ARRAY ELEMENTS TO BE SORTED
C***LPTR-WORKING ARRAY
DIMENSION LIST(1),LPTR(1)
C***CHECK INITIAL ORDER
IF(NDL.LE.l) RETURN
DO 10 1-2, NDL
IP(LIST(I-1).GT.LIST(I)) GO TO 20
10 CONTINUE
RETURN
C***BEGIN SORT
20 L2I-1
DO 100 1-1,20
M-l
L2IH-L2I
, L2I-2*L2I
IF(L2IH.GT.NDL) GO TO 110
JUP-NDVL2I+1
DO 90 J-1,JUP
N-M+L2IH
CT(N.GT.NDL) GO TO 90
KLO-K
KUP-MINO(KLO+L2I-1,NDL)
MUP-KLOH-L2IH-1
DO 60 K-KLO,KUP
IF(M.GT.NDL) GO TO 30
IF(M.GT.KUP) GO TO 30
IT(M.GT.MUP) GO TO 40
IT(LIST(M).GT.LIST(N)) GO TO 40
30 NL-M
M-M+1
GO TO SO
40 ML-N
SO
60
70
80
90
100
110
LPTR(K)-LIST(NL)
CONTINUE
DO SO KHKLO,KUP
LIST(K)-LPTR(K)
CONTINUE
M-KLO+L2I
CONTINUE
CONTINUE
RETURN
END
IS000010
ISO00020
ISO00030
ISO00040
IS000050
ISO00060
ISO00070
IS000080
ISO00090
ISO00100
IS000110
IS000120
ISO00130
IS000140
IS000150
IS000160
ISO00170
ISO00180
IS000190
ISO00200
ISO00210
ISO00220
IS000230
ISO00240
ISO00250
ISO00260
IS000270
ISO00280
IS000290
ISO00300
IS000310
ISO00320
ISO00330
ISO00340
ISO00350
ISO00360
ISO00370
ISO00380
ISO00390
ISO00400
ISO00410
IS000420
ISO00430
IS000440
ISO00450
ISO00460
IS000470
136
-------
SUBROUTINE MULTC(XCON,YCON,NPC,NPCMAX,MCFLAG) MTC00010
C***THIS SUBROUTINE DETERMINES WHETHER A CONTOUR IS REALLY A SERIES MTC00020
C***OF MULTIPLE CONTOURS. IF THIS IS FOUND TO BE THE CASE, THEN THE MTC00030
C***CONTOUR POINT NUMBERING SCHEME IS MODIFIED TO SHOW A SERIES OF MTC00040
C***CONTOURS CONNECTED TO THE FIRST CONTOUR IN THE SERIES BY INFINITELY MTC00050
C***THIN STRIPS FOR THE PURPOSE OF CALCULATING THE AREA, COKTROID MTC00060
C***COORDINATES, AND SECOND MOMENTS OF THE COMPONENT CONTOURS TAKEN MTC00070
C***AS A GROUP. MTC00080
C*** MTC00090
C*** MTC00100
C GLOSSARY OF TERMS MTC00110
C*** MTC00120
C*** MTC00130
C ISO-SIGN(+ OR -) OF THE AREA OF THE FIRST COMPONENT CONTOUR MTC00140
C ISN-SIGN(+ OR -) OF THE AREA OF THE Nth COMPONENT CONTOUR(NOT MTC00150
C INCLUDING THE FIRST COMPONENT CONTOUR) MTC00160
C K-COUNTER FOR THE INPUT SET OF CONTOUR POINTS MTC00170
C XCOUNT-COUNTER FOR THE FINAL SET OF CONTOUR POINTS MTC00180
C KFIN(N)-ENDING VALUE OF KCOUNT FOR THE Nth COMPONENT CONTOUR MTC00190
C (NOT COUNTING THE FIRST COMPONENT CONTOUR) MTC00200
C KSTART(N)-STARTING VALUE OF KCOUNT FOR THE Nth COMPONENT CONTOUR MTC00210
C (NOT COUNTING THE FIRST COMPONENT CONTOUR) MTC00220
C MCFLAG-SUBROUTINE COMPLETION CODE MTC00230
C -0(MAXIMUM NUMBER OF POINTS EXCEEDED IN THE CONTOUR POINT MTC00240
C REASSIGNMENT PROCESS—CONTOUR REJECTED) MTC00250
C -1(THE LAST IN A SERIES OF MULTIPLE CONTOURS WAS FOUND MTC00260
C HOT TO BE CLOSED—CONTOUR REJECTED) MTC00270
C -2(CONTOUR HAS FOUND TO BE A SINGLE CONTOUR(I.E. NO CONTOUR MTC00280
C CLOSURE WAS FOUND BEFORE THE FINAL CONTOUR POINT)) MTC00290
C -3(POINT REASSIGNMENT FOR THE MULTIPLE CONTOUR WAS MTC00300
C SUCCESSFULLY COMPLETED) MTC00310
C -4(ALL COMPONENT CONTOURS NOT INPUT WITH POINTS IN THE SAME MTC00320
;C ORDER. THE ORDER OF POINT INPUT FOR THE COMPONENT CONTOURS MTC00330
C HAS BEEN MADE THE SAME AS THE FIRST COMPONENT CONTOUR. MTC00340
C FOLLOWING THIS ACTION, THE POINT REASSIGNMENT FOR THE MTC00350
C MULTIPLE CONTOUR WAS SUCCESSFULLY COMPLETED.) MTC00360
C NCON-NUMBER OF COMPONENT CONTOURS NOT INCLUDING THE FIRST MTC00370
C (INCREMENTED DURING THE COURSE OF THE ANALYSIS) MTC00380
C HN-POINT COUNTERd TO (KFIN(N)-KSTART(N))+l) WITHIN COMPONENT MTC00390
C CONTOUR X MTC00400
C ICON-ARRAY CONTAINING X COORDINATES OF THE INITIAL AND FINAL SET MTC00410
C OF CONTOUR POINTS MTC00420
C YCON-ARRAY CONTAINING Y COORDINATES OF THE INITIAL AND FINAL SET MTC00430
C OF CONTOUR POINTS MTC00440
C XCONS,YCONS-WORKING ARRAYS FOR CONTOUR POINT REASSIGNMENT MTC00450
C*** . MTC00460
C*** MTC00470
DIMENSION XCON(1000),YCON(1000),XCONS(1000),YCONS(1000) MTC00480
DIMENSION KSTART(500),KFIN(500) MTC00490
NCON-1 MTC00500
XCONS(1)-XCON(1) MTC00510
YCONS(1)-YCON(1) • MTC00520
DO 100 K-2.NPC MTC00530
KSAVE-K MTC00540
XCONS(K)-XCON(K) . MTC00550
YCONS(X)-YCON(K) MTC00560
C***DETERMINE WHETHER THE CONTOUR CLOSES BEFORE THE LAST CONTOUR POINT MTC00570
C***HAS BEEN REACHED. IF SO, ASSUME THE CONTOUR IS COMPOSED OF MULTIPLE MTC00580
C***CONTOURS AT THE SAME ELEVATION. CONTINUE WITH THE ANALYSIS. IF NOT, MTC00590
C***THEN RETURN TO THE MAIN PROGRAM WITH A COMPLETION CODE OF 2. MTC00600
XF(ABS(XCON(K)-XCON(1)).LT.1.0E-15.AND.ABS(YCON(K)-YCON(1)).LT. MTC00610
41.0E-1S.AND.X.NE.NPC) GO TO 110 MTC00620
100 CONTINUE ' MTC00630
MCFLAG-2 MTC00640
GO TO 400 MTC00650
110 CONTINUE MTC00660
137
-------
4***DETERMINE THE AREA OF THE FIRST COMPONENT CONTOUR AND ITS SIGN FOR MTC00670
C***LATER USE. MTC00680
CALL ARCM(XCON,YCON,AREA,XCM,YCM,KSAVE) MTC00690
ISO— 1 MTC00700
IF(AREA.LT.O.) ISO— 1 MTC00710
KSP1-KSAVE+1 MTC00720
KSTART(1)-KSP1 MTC00730
C***STORE THE COORDINATES OF THE FIRST POINT OF THE SECOND COMPONENT MTC00740
C***CONTOUR IN THE TEMPORARY STORAGE ARRAYS. MTC00750
i XCONS(KSP1)-XCON(KSP1) MTC00760
: YCONS(KSP1)-YCON(KSP1) MTC00770
I KSP2-KSAVE+2 _ MTC00780
C***IF ONLY ONE ADDITIONAL POINT HAS BEEN SPECIFIED AFTER THE FIRST KTC00790
<***CONTOUR CLOSURE, THEN RETURN TO THE MAIN PROGRAM WITH A COMPLETION MTC00800
C***CODE OF 1. MTC00810
IF(KSP2.LE.NPC) GO TO 150 MTC00820
MCFLAG-1 MTC00830
GO TO 400 MTC00840
i 150 CONTINUE MTC00850
C***SPECIFY THE BEGINNING POINT OF THE SECOND COMPONENT CONTOUR AS KTC00860
C***(XCOMP,YCOMP). MTC00870
i XCOMP-XCON(KSPl) MTC00880
; YCOMP-YCON(KSPl) MTC00890
KCOUNT-KSP2 . MTC00900
i K-KCOUNT MTC00910
C***UP TO THIS POINT THE NUMBER OF THE INPUT AND MODIFIED CONTOUR POINTSMTC00920
C***IS STILL THE SAME. NOW ENTER THE LOOP WHICH CARRIES OUT THE POINT MTC00930
C***REASSIGNMENT PROCESS. MTC00940
200 CONTINUE MTC00950
i XCONS (KCOUNT) -XCON (K) MTC00960
i YCONS (KCOUNT) -YCON(K) MTC00970
C***HAS THE NEXT CLOSURE BEEN REACHED? IF SO, RETURN TO THE POINT MTC00980
C***OF FIRST CLOSURE(XCON(1),YCON(1)) BEFORE CONTINUING. MTC00990
IF(ABS(XCON(K)-XCOMP) .GT.1.0E-15.OR.ABS (YCON(K) -YCOMP) .GT.1.0£-15)MTC01000
tGO TO 210. MTC01010
C***SPECIFY THE END POINT FOR COMPONENT CONTOUR NCON. MTC01020
KFIN(NCON) -KCOUNT MTC01030
C***nrCREMENT COUNTER FOR THE SET OF MODIFIED CONTOUR POINTS. MTC01040
: KCOUNT-KCOUNT-H . MTC01050
C***CRECK WHETHER THE MAXIMUM NUMBER OF CONTOUR POINTS HAS BEEN EXCEEDEDMTC01060
IF(KCOUNT.LE.NPCMAX) GO TO 205
I MCFLAG-O
GO TO 400
205 CONTINUE
C***RETURN TO CLOSURE POINT FOR FIRST COMPONENT CONTOUR.
XCONS(KCOUNT)-XCON(1)
YCONS(KCOUNT)-YCON(l)
C***IHCREMENT COUNTER FOR THE ORIGINAL SET OF POINTS.
K-K+1
-------
C***CLOSURE. MTC01330
XCOMP-XCON(K) MTC01340
YCOMP-YCON(K) MTC01350
C***INCREM£NT THE COUNTER FOR THE INPUT SET OP CONTOUR POINTS. MTC01360
210 K-K+1 MTC01370
C***DETERMINE WHETHER THE NUMBER OF INPUT CONTOUR POINTS HAS BEEN MTC01380
C***EXKAUSTED. MTC01390
IF(K.LE.NPC) GO TO 250 MTC01400
MCFLAG-1 MTC01410
GO TO 400 MTC01420
250 CONTINUE MTC01430
C***INCREMENT THE COUNTER FOR THE MODIFIED SET OF CONTOUR POINTS. MTC01440
KCOUNT-KCOUNT+1 MTC01450
C***CHECK WHETHER THE NUMBER OF CONTOUR POINTS HAS BEEN EXCEEDED. MTC01460
IF(KCOUNT.LE.NPCMAX) GO TO 200 MTC01470
MCFLAG-0 MTC01480
GO TO 400 MTC01490
300 CONTINUE MTC01500
NPOKCOUNT MTC01510
C***TRANSFER THE POINT COORDINATES FROM THE TEMPORARY HOLDING ARRAYS MTC01520
C***TO THE INITIAL POINT COORDINATE ARRAYS. . MTC01530
DO 350 K-1,KCOUNT MTC01540
XCON(X)-XCONS(K) MTC01550
YCON(K)-YCONS(K) MTC01560
350 CONTINUE MTC01570
KCFLAG-3 MTC01580
C***DETERMINE WHETHER ALL COMPONENT CONTOURS HAVE THEIR POINTS INPUT MTC01590
C***IN THE SAME SENSE(CLOCKWISE OR COUNTER-CLOCKWISE). IF NOT, MODIFY MTC01600
C***THB INPUT SEQUENCES TO REFLECT THE SEQUENCE USED FOR THE FIRST MTC01610
C***COMPONENT CONTOUR. MTC01620
DO 390 N-1,NCON MTC01630
NN-0 MTC01640
DO 370 K-KSTART(N),KFIN(N),1 . MTC01650
XN-NN+1 MTC01660
ICONS(NN)-XCON(K) MTC01670
YCONS(NN)»YCON(K) MTC01680
370 CONTINUE . MTC01690
C***FIND THE AREA OF THE COMPONENT CONTOUR AND ITS SIGN. IF THE SIGN MTC01700
C***OF THE AREA Iff DIFFERENT FROM THE SIGN OF THE AREA OF THE INITIAL MTC01710
C***COMPONENT CONTOUR, THEN REVERSE THE INPUT ORDER OF THE COMPONENT MTC01720
C***CONTOUR POINTS. MTC01730
CALL ARCM(XCOKS,YCONS,AREA,XCM,YCM,NN) MTC01740
ISN-1 • MTC01750
IF(AREA.LT.O.) ISN—1 MTC01760
IF(ISN.BQ.ISO) GO TO 390 MTC01770
MCFLAG-4 . MTC01780
DO 380 K-KSTART(N),KFIN(N),1 MTC01790
XCON(K)-XCONS(NN) MTC01800
YCON(K)-YCONS(NN) MTC01810
NN-NN-1 MTC01820
380 CONTINUE MTC01830
390 CONTINUE • MTC01840
400 CONTINUE MTC01850
RETURN MTC01860
END MTC01870
139
-------
SUBROUTINE SKIPCN(IN,NPC) SKP00010
C***SUBROUTINE TO SKIP CONTOUR POINTS FOR CONTOURS WHICH ARE NOT SKP00020
C***TO BE PROCESSED SKP00030
READ(IN,*) (XDUM,YDUM,K-1,NPC) SKP00040
RETURN SKPOOOSO
END SKP00060
140
-------
SUBROUTINE SMOHNT(XCON,YCON,AR,NSLOPE,SN,CN,ANGLE,NPC, SMO00010
«XC,YC,RG,RGRAT,ORENT,ISMFLG) SMO00020
C***SUBROUTINE TO CALCULATE THE SECOND MOMENTS AND RADII OF GYRATION SMO00030
C***FOR THE INPUT CONTOUR ABOUT AXES OF EQUAL ANGULAR SPACING AND SMO00040
C***WHICH PASS THROUGH 'THE CENTROID OF THE CONTOUR IN THE PLANE OF THE SMOOOOSO
C***CONTOUR . • SMO00060
C***INITIALIZE VALUES FOR THE MAXIMUM AND MINIMUM RADII OF GYRATION SMO00070
DIMENSION SN(1),CN(1),XCON(1),YCON(1),ANGLE(1) SMOOOOSO
ISMFLG-0 SMO00090
RGMAX-0. SM000100
RGMIN-l.OE+15 SMO00110
C***BEGIN LOOP OVBR AXIS ORIENTATION VALUES SM000120
DO 200 M-1,NSLOPE SMO00130
C***INITIALIZE THE SECOND MOMENT FOR THIS AXIS TO ZERO SMO00140
SMOK-0. SMO001SO
C***BEGIN LOOP OVER CONTOUR POINTS SMO00160
C***D1»PERPENDICULAR DISTANCE TO THE AXIS LINE FROM CONTOUR POINT K SMO00170
C***D2-PERPENDICULAR DISTANCE TO THE AXIS FROM CONTOUR POINT K+l SMO00180
C***W*DISTANCE ALONG THE AXIS LINE BETWEEN THE INTERSECTION OF SMO00190
C*** PERPENDICULARS FROM ADJACENT CONTOUR POINTS(K AND K+l) SMO00200
NPCMl-NPC-1 SM000210
Dl—(XCON(1)-XC)*SN(M) + (YCON(1)-YC)*CN(M) SMO00220
DO 100 K-1,NPCM1 - SMO00230
D2— (XCON(K+1)-XC)*SN(M)+(YCON(K+1)-YC)*CN(M) SMO00240
W-(XCON(K+1)-XCON(K) ) *CN(M)+(YCON(K+1)-YCON(K)) *SN(M) SMO00250
SMOM«SMOM+(W/12.)*(D2**3+D1**3+D1*D2**2+D2*D1**2) SMO00260
01-02 SM000270
100 CONTINUE SM000280
IF(SMOH/AR.LT.O.O) ISMFLG-1 SMO00290
IF(ISMFLG.EQ.l) RETURN SMO00300
C***CALCULATE THE RADIUS OF GYRATION OF THE CONTOUR ABOUT THIS AXIS SMO00310
RG-SQRT(SMOM/AR) SMO00320
C***UPDATE THE VALUES FOR THE MAXIMUM AND MINIMUM RADII OF GYRATION SMO00330
C***AND SAVE THE ORIENTATION INDEX FOR THE AXIS HAVING THE CURRENT SMO00340
C***LARGEST RADIUS OF GYRATION . SMO00350
IF(RG.LT.RGMAX) GO TO 150 SMO00360
' RGMAX-RG . . SM000370
MMAX-M . SMO00380
150 IF(RG.GT.RGMIN). GO TO 200 SMO00390
RGMIN-RG SMO00400
200 CONTINUE . SMO00410
RG-RGMAX SMO00420
RGRAT»TRGMAX-RGMIN)/RGMAX ' SMO00430
ORENT-ANGLE(MHAX) SMO00440
RETURN SM000450
END SMO00460
141
-------
SUBROUTINE VECTOR(XBEG,YBEG,XEND,YEND,ANGLE,DX,DY) . VEC00010
C***SUBROUTINE CALCULATES THE DIRECTION(DEGREES) AND X,Y COMPONENTS VEC00020
C***FOR A VECTOR FROM (XBEG.YBEG) TO (XEND,YEND). THE COMPUTED VEC00030
C***DIRECTIONS RANGE FROM 0 TO 360 DEGREES VEC00040
PI-3.14159265 VEC00050
DX-XEND-XBEG VEC00060
DY-YEND-YBEG VEC00070
I?(ABS(DX).LT.1.0E-15.AND.ABS(DY).LT.l.OE-15) GO TO 10 VEC00080
ANGLE-(180./PI)*ATAN2(DY,DX) VEC00090
GO TO 20 VEC00100
10 WGLE-0. VEC00110
20 I?(ANGLE.LT.O.) ANGLE-360.+ANGLE VEC00120
RETURN VEC00130
END VEC00140
142
-------
HCHIT MAIN PROGRAM AND SUBROUTINE PSORTR
143
-------
PROGRAM HCRIT HCT00010
C***PROGRAM TO FIT ELLIPTICAL CONTOURS TO AN INVERSE POLYNOMIAL HILL HCT0002a
C***SHAPE FOR A RANGE OF USER SPECIFIED CRITICAL CUTOFF ELEVATIONS. HCT00030
C***THE PROGRAM PROVIDES CRITICAL ELEVATION HILL PARAMETERS FOR HCT00040
C***INPUT TO THE COMPLEX TERRAIN DISPERSION MODEL(CTDM). HCT00050
C*** HCT00060
C*** HCT00070
C GLOSSARY OF TERMS HCT00080
HCT00090
HCT00100
A(J)-SEMI-MAJOR AXIS LENGTH FOR CONTOUR J(USER COORDINATES) HCT00110
AI-INTERPOLATED VALUE OF A(J) TO A GIVEN CRITICAL ELEVATION HCT00120
AS(J)-TEMPORARY A(J) STORAGE ARRAY USED IN SORTING HCT00130
ANS-CHARACTER*! VARIABLE HOLDING THE ANSWER TO A YES(Y) OR NO(N) HCT00140
QUESTION HCT00150
B(J)-SEMI-MINOR AXIS LENGTH FOR CONTOUR J(USER COORDINATES) HCT00160
BI-INTERPOLATED VALUE OF B(J) TO A GIVEN CRITICAL ELEVATION HCT00170
BS(J)-TEMPORARY B(J) STORAGE ARRAY USED IN SORTING HCT00180
ECC(J)-ECCENTRICITY OF CONTOUR J HCT00190
ECCS(J)-TEMPORARY ECC(J) STORAGE ARRAY USED IN SORTING HCT00200
FCONFILE-CHARACTER*15 VARIABLE CONTAINING THE INPUT FILE NAME FOR HCT00210
THE FITTED CONTOUR PARAMETERS GENERATED BY PROGRAM FITCON HCT00220
FEXT-EXTRAPOLATION FACTOR USED TO ASSIGN THE SEMI-MAJOR AND HCT00230
SEMI-MINOR AXIS LENGTHS FOR THE CASE OF ONE CONTOUR AND HCT00240
A CRITICAL ELEVATION BELOW THAT SINGLE CONTOUR HCT00250
FRACT-FRACnONAL DIFFERENCE OF THE CRITICAL ELEVATION BETWEEN HCT00260
ADJACENT CONTOUR ELEVATIONS HCT00270
HC(I)-ARRAY OF CRITICAL ELEVATIONS HCT00280
HCLOW-THE LOWEST CRITICAL ELEVATION(INPUT FOR CRITICAL ELEVATION HCT00290
SELECTION MODE 2) HCT00300
HCON(J)-ELEVATION OF CONTOUR J(USER COORDINATES) HCT00310
HCONM1-HCX)N(NC)-1. HCT00320
HCONS(J)-TEMPORARY HCON(J) STORAGE ARRAY USED IN SORTING HCT00330
HHILL-HEIGHT OF THE RILL TOP ABOVE A GIVEN CRITICAL ELEVATION HCT00340
HNAME-CHARACTER*15 VARIABLE GIVING THE HILL NAME HCT00350
HTOP-HILL TOP ELEVATION(USER COORDINATES) HCT00360
ICHMOD-CRmCAL ELEVATION INPUT MODE FOR THE RILL IN QUESTION HCT00370
-1(CRITICAL ELEVATIONS WILL BE AT CONTOUR ELEVATIONS WITH HCT00380
THE' EXCEPTION OF THE UPPERMOST CONTOUR) HCT00390
-2(CRITICAL ELEVATIONS EVENLY SPACED BETWEEN A USER SUPPLIED HCT00400
C***
C
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
• C
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
LOWER ELEVATION AND THE ELEVATION OF THE UPPERMOST CONTOUR)HCT00410
IDC(J)-ID NUMBER FOR CONTOUR J
IDHILL-HILL ID NUMBER(1-999)
IN-UNIT NUMBER FOR THE FITTED HILL INPUT FILE FROM PROGRAM FITCON
LA-LENGTH PARAMETER FOR AN INVERSE POLYNOMIAL FIT ALONG THE HILL
MAJOR AXIS(USER COORDINATES)
LB-LENGTH PARAMETER FOR AN INVERSE POLYNOMIAL FIT ALONG THE HILL
MINOR AXIS(USER COORDINATES)
LPTR-WORKING ARRAY USED IN THE POINTER SORT(PSORTR)
MOOT-UNIT NUMBER FOR THE FILE (MOUTFILE) CONTAINING TERRAIN
PARAMETERS WHICH ARE PASSED TO CTDM
MOUTFILE-CHARACTER*15 VARIABLE CONTAINING THE OUTPUT FILE NAME FOR
THE PARAMETERS TO BE PASSED TO CTDM
HC-NUMBER OF FITTED CONTOURS INPUT FROM FCONFILE
NCHMAX-MAXIMUH NUMBER OF CRITICAL ELEVATIONS WHICH CAN BE ANALYZED
HCON-NUMBER OF CONTOURS USED IN FITTING A RILL FOR A GIVEN
ELEVATION
NCR-NUMBER OF CRITICAL ELEVATIONS USED
NPTR-ARRAY CONTAINING THE SORTED POINTERS RETURNED FROM SUBROUTINE
PSORTR
ONOR-MAJOR AXIS ORIENTATION IN DEGREES CLOCKWISE FROM NORTH(FOR A
CONTOUR OR A FITTED RILL)(BETWEEN 0 AND 180 DEGREES)
OREN(J)-ORIENTATION ANGLE OF THE CONTOUR J SEMI-MINOR AXIS WITH
RESPECT TO THE POSITIVE X-AXIS
ORENF-ORIENTATON OF THE MINOR AXIS OF A FITTED HILL AS MEASURED
COUNTER CLOCKWISE FROM THE POSITIVE X-AXIS(EAST)
HCT00420
HCT00430
HCT00440
HCT00450
HCT00460
HCT00470
HCT00480
HCT00490
HCT00500
HCT00510
HCT00520
HCT00530
HCT00540
HCT00550
CRITICAL HCT00560
HCT00570
HCT00580
HCT00590
HCT00600
HCT00610
HCT00620
HCT00630
HCT00640
HCT00650
HCT00660
144
-------
c
c
c
c
c
c
c
c
c
c
•c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c
c***
c***
ORENI-INTERPOLATED VALUE OF OREN(J) TO A GIVEN CRITICAL ELEVATION HCT00670
ORENS(J)-TEMPORARY OREN(J) STORAGE ARRAY USED IN SORTING HCT00680
PA-EXPONENT FOR AN INVERSE POLYNOMIAL FIT ALONG THE HILL MAJOR AXIS HCT00690
PB-EXPONENT FOR AN INVERSE POLYNOMIAL FIT ALONG THE HILL MINOR AXIS HCT00700
PFILE-CHARACTER*15 VARIABLE GIVING THE NAME OF THE CRITICAL HCT00710
ELEVATION PLOT FILE. THIS NAME MOST BE DIFFERENT THAN THE NAMEHCT00720
OF THE PLOT FILE GENERATED BY PROGRAM FITCON. BOTH PLOT FILES HCT00730
ARE EVENTUALLY BE INPUT TO THE PLOT PROGRAM.
PFLAG-PLOT GENERATION INDICATOR
-0(NO PLOT GENERATED)
-1(PLOT GENERATED)
PSORTR-SUBROUTINE FOR SORTING POINTERS(CALLED TO SORT CONTOUR
FIT PARAMETERS BY CONTOUR ELEVATION(ASCENDING ORDER))
SUM1,SUM2A,SUM2B,SUM3,SUM4A,SUM4B-SUMMATION VARIABLES USED IN THE
CALCULATION OF BEST FIT INVERSE POLYNOMIAL HILL PROFILES
SUMX,SUMY-INTERMEDIATE VARIABLES USED IN THE DETERMINATION OF THE
ORIENTATIONS OF INTERPOLATED CONTOURS AND FITTED HILLS
UPL-UNIT NUMBER FOR THE CRITICAL ELEVATION PLOT FILE
XCM(J)-X-COORDINATE OF THE CONTOUR J CENTROID(USER COORDINATES)
XCMI-INTERPOLATED VALUE OF XCM(J) TO A GIVEN CRITICAL ELEVATION
XCMS(J)-TEMPORARY XCM(J) STORAGE ARRAY USED IN SORTING
XHTOPF-AVERAGE OF THE X-COORDINATES OF CONTOUR CENTROIDS ABOVE
A GIVEN CRITICAL ELEVATION
YCM(J)-Y-COORDINATE OF THE CONTOUR J CENTROID(USER COORDINATES)
YCMI-INTERPOLATED VALUE OF YCM(J) TO A GIVEN CRITICAL ELEVATION
YCMS(J)-TEMPORARY YCM(J) STORAGE ARRAY USED IN SORTING
YHTOPF-AVERAGE OF THE Y-COORDINATES 'OF CONTOUR CENTROIDS ABOVE
A GIVEN CRITICAL ELEVATION
DIMENSION A(200),AS(200),B(200),BS(200),ECC(200),ECCS(200),
*HCON(200),HCONS(200),IDC(200),OREN(200),ORENS(200),XCM(200),
4XCMS(200),YCM(200),YCHS(200),LPTR(200),NPTR(200),HC(200)
REAL*4LA,LB
INTEGER UPL
CHARACTER*! ANS
CHARACTER*1S FCONFILE,MOUTFILE,PFILE,HNAME
C***
c***
C INITIALIZATION OF VARIABLES
C***
c***
C***SPECIFY FILE UNIT NUMBERS.
IN-14
MOOT-IS
UPL-16
C***SPECIFY CONSTANTS.
PI-3.14159263
NCHMAX-200
C***
C***
C INPUT FILE NAMES.
C***
C***
C***ENTER THE NAME OF THE INPUT FILE CONTAINING THE CONTOUR FIT
C***PARAMETERS GENERATED BY PROGRAM FITCON.
5 WRITE(*,10)
10 FORMAT(/,IX,'ENTER INPUT FILE NAME(FROM FITCON) -> *\)
READ(*,'(A)•) FCONFILE
IF(FCONFILE.EQ.« •) GO TO S
C***OPEN THE INPUT FILE.
. OPEN(IN,FILE-FCONFILE,STATUS-IOLDI)
C***ENTER THE NAME OF THE OUTPUT FILE WHICH WILL BE PASSED DIRECTLY
C***TO CTDM.
15 WRITE(*,20)
20 FORMAT(/,IX,'ENTER OUTPUT FILE NAME(FOR CTDM) ->'\)
HCT00740
HCT00750
HCT00760
HCT00770
HCT00780
HCT00790
HCT00800
HCT00810
HCT00820
HCT00830
HCT00840
HCT00850
HCT00860
HCT00870
HCT00880
HCT00890
HCT00900
HCT00910
HCT00920
HCT00930
HCT00940
HCT00950
HCT00960
HCT00970
HCT00980
HCT00990
HCT01000
HCT01010
HCT01020
HCT01030
HCT01040
HCT010SO
HCT01060
HCT01070
HCT01080
HCT01090
HCT01100
HCT01110
HCT01120
HCT01130
HCT01140
HCT011SO
HCT01160
HCT01170
HCT01180
HCT01190
HCT01200
HCT01210
HCT01220
HCT01230
HCT01240
HCT01250
HCT01260
HCT01270
HCT01280
HCT01290
HCT01300
HCT01310
HCT01320
145
-------
READ(*,'(A) •) MOOTFILE
IF(MOUTFILE.EQ.« •) GO TO 15
•C***OPEN THE OUTPUT FILE.
; OPEN (MOUT,FILE-MOUTFILE, STATUS- 'NEW')
C***
C***
C DETERMINE WHETHER A PLOT IS TO BE GENERATED.
C*** •
C***FIRST, INITIALIZE THE
-C***"NO" ANSWER.
PFLAG-0
WRITE(*,30)
PLOT FLAG INDICATOR TO CORRESPOND TO A
30 FORMAT (/, IX, 'PLOT REQUESTED? (Y/N) -> «\)
'
PFLAG-1
READ(*,(A)') ANS
IF(ANS.EQ. 'Y'.OR.ANS.EQ. 'y')
IF(PFLAG.EQ.O) GO TO 50
C***INPUT THE NAME OF THE PLOT FILE.
35 WRITE(*,40)
40 FORMAT (/, IX, 'ENTER PLOT FILE NAME -> «\)
READ(*,'(A)') PFILE
; IF ( PFILE. EQ. ' •) GO TO 35
C***OPEN THE PLOT FILE.
i OPEN (OTL.FILE-PFILE, STATUS- 'NEW')
C***WRITE "HCRIT" TO THE FIRST RECORD OF THIS PLOT FILE TO INDICATE
C***THAT THIS PLOT FILE IS GENERATED BY PROGRAM HCRIT.
WRITE (UPL, 45)
45 FORMAT (' HCRIT1)
; 50 CONTINUE
*C***
;C***
C READ DATA FROM THE FITTED CONTOUR FILE.
C***
i C***
I C***INPUT THE HILL ID NUMBER AND NAME.
I READ(IN,60) IDHILL,HNAME
i 60 FORMAT(I2,1X,A15) '
j C***INPUT THE HILL TOP ELEVATION. .
I RZAD(IN,70) HTOP . . .
; 70 FORMAT(E15.4)
jC***INPUT THE NUMBER OF FITTED CONTOURS.
: READ(IN,80) NC .
: 80 FORMAT (110)
! C***INPUT THE SORTED CONTOUR IDs. THESE IDs ARE WRITTEN TO THE
i C***PLOT FILE AND COMPARED WITH THE SORTED IDs WRITTEN TO THE
i C***PLOT FILE WRITTEN BY FITCON. THIS CHECK PREVENTS THE COMPARISON
C***OF AN ACTUAL AND A FITTED CONTOUR WHICH IN FACT REPRESENT DIFFERENT
C***CONTOURS.
I READ(IN,80) (IDC(J) ,J-1,NC)
; IF(PFLAG.EQ.O) GO TO 85
I C***WRITE TO THE PLOT FILE THE RILL ID NUMBER, KILL NAME, NUMBER
! C***OF FITTED CONTOURS, THE SORTED CONTOUR IDs, AND THE HILL TOP
| C***ELEVATION.
! WRITE(UPL,60) IDHILL,HNAME .
i WRITE (UPL, 80) NC .
! WRITE(UPL,80) (IDC(J) ,J»1,NC)
WRITE (UPL, 70) HTOP .
i 85 CONTINUE •
: C***INPUT THE CONTOUR FIT PARAMETERS FOR THE HILL IN QUESTION. .
I DO 100 J-1,NC
I READ (IN, 90) HCON(J),XCM(J),YCM(J),A(J),B(J),ECC(J),OREN(J)
! 90 FORMAT (7E15. 4)
! 100 CONTINUE
|C***CLOSE THE FITTED CONTOUR INPUT FILE.
CLOSE (IN, STATUS- 'KEEP')
HCT01330
HCT01340
HCT01350
HCT01360
HCT01370
HCT01380
HCT01390
HCT01400
HCT01410
HCT01420
HCT01430
HCT01440
HCT01450
HCT01460
HCT01470
HCT01480
HCT01490
HCT01500
HCT01510
HCT01520
HCT01530
HCT01540
HCT01550
HCT01560
HCT01570
HCT01580
HCT01590
HCT01600
HCT01610
HCT01620
HCT01630
HCT01640
HCT01650
HCT01660
HCT01670
HCT01680
HCT01690
HCT01700
HCT01710
HCT01720
HCT01730
HCT01740
HCT01750
HCT01760
HCT01770
HCT01780
HCT01790
HCT01800
HCT01810
HCT01820
HCT01830
HCT01840
HCT01850
HCT01860
HCT01870
HCT01880
HCT01890
HCT01900
HCT01910
HCT01920
HCT01930
HCT01940
HCT01950
HCT01960
HCT01970
HCT01980
146
-------
C*** HCT01990
C SORT THE CONTOUR PARAMETERS BY CONTOUR ELEVATION (IN ASCENDING ORDER) HCT02000
C BY USE OF A POINTER SORT.
C***
CALL PSORTR(HCON,NC,NPTR,LPTR)
C***REORDER THE CONTOUR FIT PARAMETERS BASED UPON THE RESULTS OF THE
C***POINTER SORT.
DO 110 J-1,NC
HCONS(J)-HCON(NPTR(J))
AS(J)-A(NPTR(J))
BS(J)-B(NPTR(J))
ECCS(J)-ECC(NPTR(J))
ORENS(J)-OREN(NPTR(J))
XCMS(J)-XCM(NPTR(J))
YCMS(J)-YCM(NPTR(J))
110 CONTINUE
DO 120 J-1,NC
i HCON(J)-HCONS(J)
A(J)-AS(J)
B(J)-BS(J)
ECC(J)-ECCS(J)
OREN(J)-ORENS(J)
XCM(J)-XCMS(J)
YCM (J)-YCMS (J)
120 CONTINUE
i IF(PFLAG.EQ.O) GO TO 123
iC***WRITE THE SORTED CONTOUR ELEVATIONS TO THE PLOT FILE.
DO 122 J-1,NC
WRITE(UPL,121) HCON(J)
121 FORMAT(E15.4)
122 CONTINUE
123 CONTINUE
iC*«*
! C***
C DETERMINE CRITICAL ELEVATIONS TO BE USED FOR FITTING CUTOFF
C HILLS.
C***
i C***
iC***TWO MODES ARE AVAILABLE FOR THE INPUT OF CRITICAL ELEVATIONS.
C***THE USER MAY SPECIFY THAT EACH CONTOUR LEVEL(WITH THE EXCEPTION
C***OF THE UPPERMOST CONTOUR) IS TO BE SPECIFIED AS A CRITICAL
C***ELEVATION, OR THE USER MAY ASK FOR UP TO A MAXIMUM OF NHCMAX
,C***CRTTICAL ELEVATIONS EVENLY SPACED BETWEEN A USER SPECIFIED LOWER
C***BLEVATION AND THE UPPER MOST CONTOUR OF THE HILL.
; 125 WRITE(*,130)
130 FORMAT(//,22X,'SPECIFY CRITICAL HEIGHT SELECTION MODE',/,
HCT02010
HCT02020
HCT02030
HCT02040
HCT02050
HCT02060
HCT02070
HCT02080
HCT02090
HCT02100
HCT02110
HCT02120
HCT02130
HCT02140
HCT02150
HCT02160
HCT02170
HCT02180
HCT02190
HCT02200
HCT02210
HCT02220
HCT02230
HCT02240
HCT022SO
HCT02260
HCT02270
HCT02280
HCT02290
HCT02300
HCT02310
HCT02320
HCT02330
HCT02340
HCT02350
HCT02360
HCT02370
HCT02380
HCT02390
HCT02400
HCT02410
HCT02420
HCT02430
HCT02440
HCT02450
HCT02460
HCT02470
HCT02480
HCT02490
HCT02500
HCT02510
HCT02520
HCT02530
C22X,'!.) AT ALL CONTOUR ELEVATIONS EXCEPT UPPERMOST',/,
C22X,*2.) EVENLY SPACED BETWEEN A USER SUPPLIED ELEVATION',/
S26X,'AND THE UPPERMOST CONTOUR ELEVATION',/,
S26X,'CHOICE?(1 OR 2) -> *\)
READ(*,'(BN,I1)«,ERR-125) ICHMOD
IF(ICHMOD.EQ.l) GO TO 150
IF(ICHMOD.EQ.2) GO TO 170
WRTTE(*,140)
140 FORMAT(/,IX,»***ERROR*** SELECTION MODE OUT OF RANGE—TRY AGAIN')HCT02S40
I GO TO 125 . HCT02550
|C***CRITICAL ELEVATION SELECTION MODE 1 HCT02560
|C***THE NUMBER OF CRITICAL ELEVATIONS WILL BE ONE LESS THAN THE NUMBER HCT02S70
iC***OF CONTOURS. HCT02580
i ISO NCR-NC-1 HCT02S90
IF(NCR.CT.O) GO TO 155 HCT02600
i WRTTE(*,1S1) HCT02610
151 FORMAT(/,IX,'SINCE THERE IS ONLY ONE CONTOUR, THE CONTOUR SELECTIOHCT02620
i CN MODE 1 CANNOT BE USED.',/,IX,'MODE 2 WILL BE USED INSTEAD.')- HCT02630
:C***RESET THE CRITICAL ELEVATION SELECTION MODE. HCT02640
147
-------
ICHMOD-2
GO TO 170
155 DO 160 I-1,HCR
HC(I)-HCON(I)
160 CONTINUE
GO TO 250
C***CRITICAL ELEVATION SELECTION MODE 2
C***READ IN NUMBER OF CRITICAL ELEVATIONS.
170 WRITE(*,180)
HCT02650
HCT02660
HCT02670
HCT02680
HCT02690
HCT02700
HCT02710
HCT02720
HCT02730
180 FORMAT(/,1X, • INPUT THE NUMBER OF CRITICAL ELEVATIONS (1-200) -> '\)HCT02740
. READ(*,'(BN,I3) «,ERR-170) NCR HCT02750
k' IF(NCR.LE.NCHMAX.AND.NCR.NE.O) GO TO 200 HCT02760
WRITE <*, 190) HCT02770
190 FORMAT (/, IX, '***ERROR*** NUMBER OF CRITICAL ELEVATIONS OUT OF RANHCT02780
*E—TRY AGAIN') HCT02790
GO TO 170 HCT02800
C***INPUT THE LOWEST CRITICAL ELEVATION. HCT02810
200 WRITE(*,210) HCT02820
210 FORMAT (/, IX, 'INPUT THE LOWEST CRITICAL ELEVATION -> *\) HCT02830
215 R£AD<*,«(BN,F10.0)) «,ERR-200) HCLOW HCT02840
C***CHECK WHETHER THE LOWEST CRITICAL ELEVATION IS OVER 1 ELEVATION UNITHCT02850
C***ABOVE THE HIGHEST CONTOUR ELEVATION. IF SO, ASK THE USER TO INPUT HCT02860
C***ANOTHER VALUE FOR THE LOWEST CRITICAL ELEVATON.
: HCONMl-HCON(NC)-!. •
IF(HCLOW.LT.HCONMl) GO TO 230
WRITE (*, 220) HCOHM1
220 FORMAT (/, IX, 'LOWEST CRITICAL ELEVATION MUST BE LESS THAN',E15.4
;' »,/, IX, 'TRY AGAIN') '
: GO TO 215
C***ASSIGN THE CRITICAL ELEVATIONS.
C***HCLOW WILL BE THE FIRST ELEVATION. THERE WILL BE NCR-1 ADDITIONAL
C***CRITICAL ELEVATIONS ABOVE HCLOW HAVING A SPACING EQUAL TO DELC,
C***WHERE DELO(HCON(NC)-HLOW)/NCR. THE HIGHEST CRITICAL ELEVATION
C***WILL BE A DISTANCE OF DELC BELOW THE UPPERMOST CONTOUR LEVEL.
230 DELC- (HCON(NC) -HCLOW) /FLOAT (NCR) .
DO 240 I-1,NCR
HC(I)-HCLOW+(I-1)*DELC
240 CONTINUE
i 250 CONTINUE
IF(PFLAG.EQ.O) GO TO 251
C***WRITB THE NUMBER OF CRITICAL ELEVATIONS TO THE PLOT FILE.
1 WRITE (UPL, 80) NCR
251 CONTINUE
t***ASSIGNMENT OF CRITICAL ELEVATIONS COMPLETED.
C***
t***
C WRITE THE HILL ID, THE NUMBER OF CRITICAL ELEVATIONS, THE RILL
C TOP ELEVATION, AND THE HILL NAME TO THE CTDM INPUT FILE.
1C***
C***
! WRITE (MOUT, 260) IDHILL,NCR,HTOP,HNAME
! 260 FORMAT(5X,I2,1X,I2,10X,E10.4,10X,A15) '
C***
I
FOR EACH CRITICAL ELEVATION, DETERMINE THE PARAMETERS WHICH BEST
DESCRIBE THE ELLIPTICAL TERRAIN CONTOUR AT THAT ELEVATION. THESE
HCT02870
HCT02880
HCT02890
HCT02900
HCT02910
HCT02920
HCT02930
HCT02940
HCT02950
HCT02960
HCT02970
HCT02980
HCT02990
HCT03000
HCT03010
HCT03020
HCT03030
HCT03040
HCT03050
HCT03060
HCT03070
HCT03080
HCT03090
HCT03100
HCT03110
HCT03120
HCT03130
HCT03140
HCT03150
HCT03160
HCT03170
HCT03180
HCT03190
HCT03200
PARAMETERS ARE WRITTEN TO THE CTDM INPUT FILE FOR USE IN THE "WRAP" HCT03210
C
e
e
e
c***
c***
PLUMB CALCULATION IN CTDM. 17 THE CRITICAL ELEVATION DOES NOT CO-
INCIDE WITH AN INPUT CONTOUR(I.E. ICHMOD-2), THEN THE PARAMETERS
MUST BE DETERMINED BY A SIMPLE INTERPOLATION OF FITTED CONTOUR
PARAMETERS BASED ON ELEVATION. THE INTERPOLATION OF THE OREN-
TATION VALUES IS A VECTOR INTERPOLATION WITH THE VECTORS WEIGHTED
WITH THE ECCENTRICITY OF THE CONTOUR.
I7(ICHMOD.EQ.2) GO TO 290
HCT03220
HCT03230
HCT03240
HCT03250
HCT03260
HCT03270
HCT03280
HCT03290
HCT03300
148
-------
C***CASE I—CRITICAL ELEVATIONS COINCIDE WITH CONTOUR ELEVATIONS. HCT03310
DO 280 J-1,NCR HCT03320
C***FIND THE ORIENTATION OF THE MAJOR AXIS MEASURED CLOCKWISE FROM HCT03330
C***NORTH(BETWEEN 0 AND 180 DEGREES). HCT03340
ONOR-ISO.-OREN(J) HCT03350
IF(ONOR.LT.O.) ONOR-360.+ONOR HCT03360
IF(ONOR.GT.180.) ONOR-ONOR-180. HCT03370
WRITE (MOOT, 270) HC (J)-, XCH (J) ,YCH(J) ,ONOR,A(J) ,B(J) HCT03380
270 FORMAT(F10.3,2E10.4,3F10.3) HCT03390
280 CONTINUE HCT03400
' GO TO 360 HCT03410
C***CASE 2—CRITICAL ELEVATIONS EVENLY SPACED BETWEEN HCLOW AND THE HCT03420
C***UPPERMOST CONTOUR HCT03430
290 DO 350 1-1,NCR HCT03440
DO 300 J-1,NC HCT03450
JK-J HCT03460
IF(HCON(J).GT.HC(I)) GO TO 310 HCT03470
300 CONTINUE HCT03480
310 IF(JK.GT.l) GO TO 320 HCT03490
C***IF THE CRITICAL ELEVATION IS BELOW THE LOWEST CONTOUR, THEN • HCT03500
C***EXTRAPOLATE THE VALUES FOR THE CONTOUR ORIENTATION, CENTROID HCT03510
C***COORDINATES, AND SEMI-MAJOR AND SEMI-MINOR AXIS LENGTHS USING THE HCT03520
C***VALUES OF THESE PARAMETERS FOR THE LOWEST TWO CONTOURS. IF THERE HCT03530
:C***IS ONLY ONE CONTOUR, THEN THE VALUES FOR THE ORIENTATION AND HCT03540
C***CENTROID COORDINATES OF THE CRITICAL ELEVATION CONTOUR ARE SET HCT03550
C***EQUAL TO THE CORRESPONDING VALUES FOR THE SINGLE CONTOUR. THE HCT03560
C***SEMI-MAJOR AND SEMI-MINOR AXIS LENGTHS FOR THE CRITICAL ELEVATION HCT03570
C***CONTOUR ARE EXTRAPOLATED BY ASSUMING A ZERO AREA CONTOUR AT THE HCT03580
C***HILL TOP ELEVATION. HCT03590
IF(MC.EQ.l) GO TO 315 HCT03600
JK-2 HCT03610
GO TO 320 HCT03620
315 XOd-XCM(l) HCT03630
- YCMI-YCM(l) HCT03640
ORENI-OREN(l) HCT03650
FEXT-(HTOP-HC(I))/(HTOP-HCON(1)) HCT03660
AI-A(1)*FEXT HCT03670
BI-B(1)*FEXT HCT03680
GO TO 340 HCT03690
C***INT£RPOLATE TO FIND CONTOUR PARAMETERS AT THE Ith CRITICAL HCT03700
C***ELEVATION. HCT03710
320 FRACT-(HC(I)-HCON(JK-l))/(HCON(JK)-HCON(JK-l)) HCT03720
XCMI-XCM(JK-l)+FRACT*(XCM(JK)-XCM(JX-l)) HCT03730
YCMI-YCM(JK-l)+FRACT*(YCM(JK)-YCM(JK-l)) HCT03740
AI-A(JK-l)+FRACT*(A(JK)-A(JK-l)) HCT03750
BI-B(JK-1)+FRACT*(B(JK)-B(JK-l)) HCT03760
C***DO NOT ALLOW AI AND BI TO DECREASE WITH ELEVATION. HCT03770
IF(AI.LT.A(JK-1)) AI-A(JK-l) HCT03780
IF(BI.LT.B(JK-1)) BI-B(JX-l) HCT03790
C***INTERPOLATB THE ORIENTATION VECTORIALLY WITH THE ELLIPSE HCT03800
C***ECCENTRICITY USED AS A WEIGHTING FACTOR. HCT03810
SUMX-ECC(JK-1)*COS(PI*OREN(JK-1)/180.)+FRACT*(ECC(JK)* HCT03820
4COS(PI*OREM(JR)/180.)-ECC(JK-l)*COS(PI*OREN(JK-1)/180.)) HCT03830
SUMY«ECC(JK-l)*SIH(PI*OREN(JK-l)/180.)-fFRACT*(ECC(JR)* HCT03840
«SIH(PI*OREN(JK)/180.)-ECC(JK-1)*SIN(PI*OREN(JK-1)/180.)) HCT03850
C***AVOID CALLING THE ATAN2 FUNCTION WITH BOTH ARGUMENTS BEING HCT03860
C***EFFECTIVELY ZERO. . HCT03870
IF(ABS(SUMX).LT.1.0E-8.AND.ABS(SUMY).LT.l.OE-8) GO TO 330 HCT03880
ORENI-(180./PI)*ATAN2(SUMY,SUMX) HCT03890
GO TO 340 HCT03900
330 ORENI-O. HCT03910
C***IF THE EXTRAPOLATION PROCESS GIVES AN ELLIPSE WITH A MINOR AXIS HCT03920
C***GREATER THAN A MAJOR AXIS, THEN ASSUME THAT THE AXES ARE EQUAL HCT03930
C***AND THAT THE ELLIPSE HAS THE SAME AREA. HCT03940
340 IF(AI.GE.BI) GO TO 345 HCT03950
AI-SQRT(AI*BI) HCT03960
149
-------
BI-AI
: 345 CONTINUE
C***FIND THE ORIENTATION OF THE INTERPOLATED CONTOUR MAJOR AXIS AS
C***MEASURED CLOCKWISE FROM NORTH ( BETWEEN 0 AND 180 DEGREES).
! OHOR-180.-ORENI
IF(ONOR.LT.O.) ONOR-360.+ONOR
IFfONOR.GT.180.) ONOR-ONOR-180.
WRITE (MOOT, 270) HC(I) ,XCMI,YCMI,ONOR,AI,BI
350 CONTINUE
! 360 CONTINUE
C***THE WRITING OF BEST FIT CONTOUR ELLIPSE PARAMETERS FOR CUTOFF
C***ELEVATIONS TO THE CTDM INPUT FILE HAS BEEN COMPLETED.
C***
'C DETERMINE THE FITTED HILL PARAMETERS FOR EACH CRITICAL CUTOFF
C ELEVATION AND WRITE THESE PARAMETERS TO BOTH THE PLOT FILE AND
C THE CTDM INPUT FILE.
c***
; DO 500 I-1,NCR
C***ZERO OUT SUMMATION VARIABLES.
SUM1-0.
; SUM2A-0.
SUM2B-0.
; SUM3-0.
SUM4A-0.
! SUM4B-0.
; SDMX-0.
: SUMY-0.
XHTOPF— 0 . »
\ YHTOPF-0.
NCOH-0
;C***CALCULATE THE HILL HEIGHT ABOVE THE CRITICAL HEIGHT.
; HHILL-HTOP-HC(I)
DO 400 J-l.NC
C***CONTOUR ELEVATIONS USED IN FITTING THE PORTION OF THE HILL ABOVE
C***THE CRITICAL ELEVATION MUST BE AT LEAST ONE UNIT ABOVE THE CRITICAL
C***ELEVATION.
< IF(HCON(J).LE.HC(I)+1.) GO TO 400
BCON-NCON+1
FJ-ALOG (HHILL/ (HCON ( J) -HC ( I) ) -1 . )
SUM1-SUM1+FJ
SUM3»SUM3+FJ**2
SUM2A-SUH2A+ALOG(A(J))
; SUM2B-SUM2B+ALO<3(B(J)
SUM4A-SUM4A+ALOG(A(J) ,
SUM4B-SUM4B+ALOG(B(J)
*FJ
*FJ
SUMX-StJMX+ECC(J) *COS(PI*OREN(J)/180.)
SUMY-SUMY+ECC(J)*SIN(PI*OREN(J)/180.)
XHTOPF-XHTOPF-I-XCM(J)
YHTOPF-YHTOPF+YCM(J)
400 CONTINUE
: IF(NCON.EQ.l) GO TO 410
LA-EXP((SUM2A*SUM3-SUM4A*SUM1)/(NCON*SUM3-SUM1**2))
! LB-EXP({SUM2B*SUM3-SUM4B*SUM1)/(NCON*SUM3-SUM1**2))
PA-(NCON*SUM3-SUM1**2)/(NCON*SDM4A-SUM1*SUM2A)
! PS- (NCON*SUM3-SUM1**2 ) / (NCON*SUM4B-SOMl*StJH2B)
C***NEGATTVE EXPONENTS NOT ALLOWED
! PA-ABS(PA)
I PB-ABS(PB)
GO TO 420
C***IF ONLY ONE CONTOUR IS USED IN THE RILL FIT, ONE MUST ASSUME
C***THAT THE EXPONENTS IN'THE INVERSE POLYNOMIAL FIT ARE BOTH 2.
410 CONTINUE
PA-2.
PB-2.
HCT03970
HCT03980
HCT03990
HCT04000
HCT04010
HCT04020
HCT04030
HCT040-TO
HCT04050
HCT04060
HCT04070
HCT04080
HCT04090
HCT04100
HCT04110
HCT04120
HCT04130
HCT04140
HCT04150
HCT04160
HCT04170
HCT04180
HCT04190
HCT04200
HCT04210
HCT04220
HCT04230
HCT04240
HCT04250
HCT04260
HCT04270
HCT04280
HCT04290
HCT04300
HCT04310
HCT04320
HCT04330
HCT04340
HCT04350
HCT04360
HCT04370
HCT04380
HCT04390
HCT04400
HCT04410
HCT04420
HCT04430
HCT04440
HCT04450
HCT04460
HCT04470
HCT04480
HCT04490
HCT04500
HCT04510
HCT04520
HCT04530
HCT04540
HCT04550
HCT04560
HCT04570
HCT04580
HCT04590
HCT04600
HCT04«10
HCT04620
ISO
-------
LA-A(NC)/(HHILL/(HCON(NC)-HC(I))-!.)**(!-/PA) HCT04630
LB-B(NC)/(HHILL/(HCON(NC)-HC(I))-1.)**(1./PB) HCT04640
C***AVOID CALLING THE ATAN2 FUNCTION WITH BOTH ARGUMENTS BEING. HCT04650
C***EFFECTIVELY ZERO. HCT04660
420 IF(ABS(SUHX).LT.l.OE-8.AND.ABS(SUMY).LT.l.OE-8) GO TO 430 HCT04670
ORENF-(180./PI)*ATAN2(SUMY,SUMX) . HCT04680
GO TO 440 . HCT04690
430 ORENF-0. HCT04700
C***FIND THE ORIENTATION OF THE MAJOR AXIS AS MEASURED CLOCKWISE FROM HCT04710
C***NORTH(BETWEEN O AND 180 DEGREES). HCT04720
440 ONOR-180.-ORENF . HCT04730
IF(ONOR.LT.O.) ONOR-360.+ONOR HCT04740
IF(ONOR.GT.180.) ONOR-ONOR-180. HCT04750
XHTOPF-XHTOPP/FLOAT(NCON) HCT04760
YHTOPF-YHTOPF/FLOAT(NCON) HCT04770
IF(PFLAG.EQ.O) GO TO 455 HCT04780
C***WRXT£ THE FITTED HILL PARAMETERS TO THE PLOT FILE. HCT04790
WRITE(UPL,450) HC(I),XHTOPF,raTOPF,ORENF,PA,PB,LA,LB HCT04800
450 FORMAT(8E15.4) HCT04810
455 CONTINUE HCT04820
C***WRTTE THE FITTED HILL PARAMETERS TO THE CTDM INPUT FILE. HCT04830
WRITE(MOOT,460) HC(I),XHTOPF,YHTOPF,ONOR,PA,PB,LA,LB HCT04840
460 FORMAT(F10.3,2E10.4,5F10.3) HCT04850
500 CONTINUE HCT04860
STOP HCT04870
END HCT04880
151
-------
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-POINT£R ARRAY
C***LPTR-WORKING ARRAY
DIMENSION ARRAY(1),NPTR(1) ,LPTR(1)
C***CHECK INITIAL ORDER
Il-NPTR(l)
IF(MDL.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
rP(ARRAY(Il) .GT.ARRAY(I2)) GO TO 30
11-12
20 CONTINUE
RETURN
C***SET UP POINTER ARRAY
30 DO 40 I-1,NDL
MPTR(I)-I
1 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-H+L2IH
IF(N.GT.NDL) .GO TO 110
KLO-M
XUP-iflNO (KLO+L2I-1,NDL)
MUP-XLO+L2IH-1
DO 80 K-KLO,KUP
IF(N.GT.NDL) GO TO 50
IF(N.GT.KUP) GO TO 50
IF(M.GT.MUP) GO TO 60
»( ARRAY (HPTR(M)).GT. ARRAY (NPTR(N) ) ) GO TO 60
50. NL-M
M-M+1
GO TO 70
60 WL-N
70 LPTR(K)-NI»TR(NL)
80 CONTINUE
90 DO 100 K-KLO,KUP
VPTR(X)-LPTR(K)
100 CONTINUE
M-KLO+L2I
110 CONTINUE
IF(L2I.GE.NDL) GO TO 130
120 CONTINUE
130 RETURN
END
PS000010
PSO00020
PSO00030
PS000040
PS000050
PS000060
PSO00070
PSO00080
PSO00090
PSO00100
PSO00110
PS000120
PS000130
PS000140
PS000150
PS000160
PS000170
PS000180
PSO00190
PS000200
PS000210
PS000220
PSO00230
PS000240
PSO00250
PS000260
PS000270
PS000280
PS000290
PS000300
PS000310
PSO00320
PSO00330
PS000340
PSO00350
PSO00360
PSO00370
PSO00380
PSO00390
PS000400
PSO00410
PSO00420
PSO00430
PSO00440
PSO00450
PS000460
PSO00470
PSO00480
PSO00490
PSO00500
PSO00510
PSO00520
PSO00530
PSO00540
PSO00550
PSO00560
PSO00570
PSO00580
PSO00590
PSO00600
152
-------
PLOTCOH
153
-------
10 'Program to plot contours for actual and fitted hills on a display
20 'terminal with 320(horizontal)x200(vertical) resolution in color
30 'or 640(horizontal)x200(vertical) resolution in black and white
40 'Clear the screen.
50 CTiP
60 'Disable the display of function keys to allow more space for
70 'plotting.
80 KEY OFF
90 DEFINT I-N
100 'Dimension the arrays for contour elevations, contour identification
110 'numbers(from both FITCON and HCRIT), and the array for storing the
120 'plot of digitized contours(unedited or edited).
130 DIM HCON(200),IDC1(200),IDC2(200),IAR(8002)
140 LOCATE 12,15
150 'Input the name of the plot file from program FITCON.
160 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
170 ON ERROR GOTO 3190
180 OPEN PLOT1$ FOR INPUT AS fl
190 ON ERROR GOTO 0
200 'Make sure that this plot file was generated by program FITCON.
210 INPUT!l, PF1$
220 IF PF1$-"FITCON" THEN GOTO 280
230 CLS
240 LOCATE 10,15
250 PRINT PLOT1S « IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN1*
260 CLOSE fl
270 GOTO 140
280 CLS
290 'Input the hill identification number, hill name, hill center
300 'coordinates, number of fitted contours, and the identification
310 'numbers for the fitted contours.
320 INPUT!1, IDH1,HNAME1$
330 INPUT*1, XHTOP,YHTOP
340 INPUT*1, NCI
350 FOR J-l TO NCI
360 INPUT*1,IDC1(J)
370 NEXT J
380 'Input the plot boundaries for the unedited contours.
390 INPUT*1, XMIN1,XMAX1,YMIN1,YMAX1
400 'Input the plot boundaries for the edited contours.
410 INPUT*1, XMIN2,XMAX2,YMIN2,YMAX2
420 LOCATE 10,22
430 'Select the type of display.
440 PRINT "SELECT TYPE OF DISPLAY*
450 PRINT
460 PRINT TAB(22) "1.) Low resolution with color"
470 PRINT TAB(22) "2.) High resolution black and white"
480 PRINT
490 INPUT » Choice? (l o^r 2)—>";RFLAG*
500 CLS
510 LOCATE 10,22
520 'Select the type of contours to be displayed.
530 PRINT "SELECT THE CONTOUR TYPE FOR DISPLAY"
540 PRINT
550 PRINT TAB(22) "1.) Unedited Contours"
560 PRINT TAB(22) "2.) Edited Contours"
570 PRINT
580 INPUT « Choice?(1 or 2)—>";DFLAG%
590 CLS
600 'Set plot boundaries, scale factors, and colors.
154
-------
610 SCRCX-320!:DSCRX-468!:SCRCY-104!:DSCRY-190!:RATIO-1.3574
620 IF RFLAG*-! THEN SCRCX-1601:DSCRX»2051:RATIO-1.5437
630 IF DFLAG%-2 THEN GOTO 690
640 XO(XMINl+XMAXl)/2!
650 YO(YMINH-YMAXl)/2!
660 DX-XMAX1-XMIN1
670 DY-YMAX1-YMIN1
680 GOTO 730
690 XO(XMIN2+XMAX2)/2!
700 YC-(YMXN2+YMAX2)/2!
710 DX-XMAX2-XMIN2
720 DY-YMAX2-YMIN2
730 IF DX/DY-2 AND ABS(X-Xl)<1E-15 AND ABS(Y-Yl)<1E-15 THEN GOTO 1310
1120 'Scale the point X,Y for plotting.
1130 XS-SCRCX+(X-XC)*DSCRXr>DD
1140 YS«SCRCY-(Y-YC)*DSCRYDDD
1150 IF DUPFLG%»0 GOTO 1270
1160 'One of the multiple contours has been closed. Move to the new point
1170 'without drawing a line. Substitute the current point for the
1180 'previous individual contour beginning point.
1190 XOLD-X
1200 YOLD-Y
155
-------
1210 DUPFLG*-0
1220 PSET(XS,YS),IC
1230 GOTO 1310
1240 'Determine whether one of the individual multiple contours has been
1250 'closed. If so, set the closure indicator DUPFLG* to 1 and
1260 'increment the contour closure counter IFR by 1.
1270 IP ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG*-1:IFR-IFR+1
1280 'Draw a line from the previous point to the current point.
1290 LINE -(XS,YS),IC
1300 'End loop over contour points.
1310 NEXT K
1320 I? DFLAG%<> 1 THEN GOTO 1390
1330 'Skip over edited contours.
1340 INPOTfl, NPC
1350 FOR K-l TO NPC
1360 INPUTfl,DUMX,DUMY
1370 NEXT K
1380 'End loop over contours.
1390 NEXT J
1400 'Scale hill center coordinates.
1410 XSHOSCRCX+(XHTOP-XC)*DSCRXDDD
1420 YSHC»SCRCY-(YHTOP-YC)*DSCRYDDD
1430 XUL-XSHC-1
1440 XLR-XSHC+1
1450 YUL-YSHC-1
1460 YLR-YSHC+1
1470 'Plot a 3x3 box of points centered at the hill center.
1480 LINE(XUL,TOL)-(XLR,YLR),IC,BF
1490 I? RFLAG*-! THEN GXMX%»319 ELSE GXMX%»639
1500 'Store the plot of digitized contours in array IAR.
1510 GET (0,0)-(GXMX%,199),IAR
1520 PRINT HNAMEIS • INPUT CONTOURS'1
1530 'Pause until user presses any key. Program will terminate if the
1540 'user presses the ESC key.
1550 GOSUB 3410
1560 CLS
1570 'Change color to magenta for plotting fitted contours.
1580 IF RFLAG%-1 THEN IC-2
1590 'Restore the plot of digitized contours.
1600 POT (0,0),IAR,PSET
1610 'Begin loop over contours.
1620 FOR J-l TO NCI
1630 'Input ellipse parameters for each contour: ellipse centroid
1640 'coordinates, semi-axes lengths, and the orientation of the minor
1650 'axis with respect to the positive x-axis.
1660 INPUT!1, XCM,YCM,A,B,OR£N
1670 'Determine the orientation of the major axis with respect to the
1680 'positive x-axis
1690 OREN-OREN-901
1700 CSE-COS(.017453*OREN)
1710 SNE-SIN(.017453*OREN)
1720 XP-A
1730 XFIT-XCM+XP*CSE
1740 YFIT-YCM+XP*SNE
1750 XS-SCRCX+(XFIT-XC)*DSCRXDDD
1760 YS-SCRCY-(YFIT-YC)*DSCRYDDD
1770 'Move to a point at the end of the ellipse semi-major axis.
1780 PSET(XS,YS)
1790 A2-AA2
1800 B2-B*2
156
-------
1810 'Draw an ellipse with 120 points.
1820 FOR L-l TO 120
1830 THO-L*.05276
1840 R-SQR(1!/(COS(THC)*2/A2+SIN(THC)*2/B2))
1850 XP-R*COS(THC)
1860 YP-R*SIN(THC)
1870 XFIT-XCM+XP*CSE-YP*SNE
1880 YFIT-YCM+XP*SNE+YP*CSE
1890 XS-SCRCX+(XFIT-XC)*DSCRXDDD
1900 YS-SCRCY-(YFIT-YC)*DSCRYDDD
1910 LINE -(XS,YS),IC
1920 NEXT L
1930 'End loop over contours.
1940 NEXT J
1950 PRINT HNAME1$ " FITTED CONTOURS*
1960 'Pause until the user presses any key. If the user presses the ESC
1970 'key, then program execution will terminate.
1980 GOSUB 3410
1990 CLS
2000 'Begin plotting contours for fitted cutoff hills.
2010 'Go to text mode for user input.
2020 SCREEN 2:SCREEN 0
2030 LOCATE 12,19
2040 'Determine whether fitted hill contours are to be displayed.
2050 INPUT " DISPLAY FITTED CUTOFF HILL CONTOURS?(Y/N)->";ANS$
2060 IF ANS$-"N" THEN SYSTEM
2070 IF ANS$-"n" THEN SYSTEM
2080 CLOSE fl
2090 LOCATE 14,15
2100 'Input the name of the plot file from program RCRIT.
2110 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM HCRIT";PLOT2$
2120 ON ERROR GOTO 3220
2130 OPEN PLOT2$ FOR INPUT AS fl
2140 ON ERROR GOTO 0
2150 'Make sure the plot file was generated by program HCRIT.
2160 INPUTfl, PF2$
2170 IF PF2$-"HCRIT" THEN GOTO 2230
2180 CLS
2190 LOCATE 12,20
2200 PRINT PLOT2$ " IS NOT A FILE GENERATED BY PROGRAM HCRIT-TRY AGAIN"
2210 CLOSE fl
2220 GOTO 2090
2230 CLS
2240 'Check whether the hill identification number, hill name, number
2250 'of fitted contours, and contour identification numbers match
2260 'those from the FTTCON plot file.
2270 INPUTfl, IDH2,HNAME2$
2280 17 IDH20IDH1 THEN GOTO 3250
2290 IF HNAME1$<>HNAME2$ THEN GOTO 3280
2300 INPUTfl, NC2
2310 IF NC10NC2 THEN GOTO 3310
2320 FOR J-l TO NC2
2330 INPUTfl, IDC2(J)
2340 IF IDC1(J)OIDC2(J) THEN GOTO 3340
2350 NEXT J
2360 'Return to graphics mode.
2370 IF RFLAG4-1 THEN SCREEN 1:IO2 ELSE SCREEN 2:IC-1
2380 IF RFLAG*»1 THEN COLOR 9,1
2390 'Input hill top elevation and contour elevations.
2400 INPUTfl, HTOP
157
-------
2410 FOR J-l TO NC2
2420 INPUT*!, HCON(J)
2430 NEXT J
2440 'Input number of critical elevations.
2450 INPUT*1, NCR
2460 'Begin loop over critical elevations.
2470 FOR 1-1 TO NCR
2480 'For each critical elevation, input the critical elevation, cutoff
2490 'hill centroid coordinates, orientation of the hill minor axis
2500 'with respect to the positive x-axis, and the inverse polynomial
2510 'fit parameters for each hill axis.
2520 INPUTtl, HC,XHTOPF,YHTOPF,ORENF,PA,PB,RIA,RLB
2530 'Determine the orientation of the major axis with respect to the
2540 'positive x-axis.
2550 ORENF-ORENF-90!
2560 CSE-COS(.017453*OR£NF)
2570 SNE-SIN(.017453*ORENF)
2580 'Retrieve background plot of digitized contours(unedited or edited).
2590 PUT (0,0),IAR,PSET
2600 'Begin loop over contours.
2610 FOR J-l TO NC2
2620 'Contours must be at least one elevation unit higher than the
2630 'critical elevation if their elevations are to be used for the display
2640 'of contours on the cutoff hill.
2650 IF HCON(J)<-HC+1! THEN GOTO 3020
2660 FLOG-LOG((HTOP-HC)/(HCON(J)-HC)-1!)
2670 AFIT-RIA*EXP((1!/PA)*FLOG)
2680 BFIT-RLB*EXP((11/PB)*FLOG)
2690 'The equation for the inverse polynomial contour is
2700 • (XP/AFIT)**PA+(YP/BFIT)**PB-1
2710 'in the coordinate system in which the x and y primed axes
2720 'coincide with the major and minor axes of the hill respectively.
2730 'Begin loop to calculate 800 contour point coordinates.
2740 FOR L-l TO 200
2750 17 L>99 GOTO 2810
2760 'Let x primed be the independent variable.
2770 XPOL-L*.01*AFIT
2780 YPOL-BFIT*(ll-(XPOL/AFrr)APA)A(ll/PB)
2790 GOTO 2840
2800 'Let y primed be the independent variable.
2810 YPOL-(L-100)*.01*BFIT
2820 XPOL-AFIT*(ll-(YPOVBFIT)APB)*(l!/PA)
2830 'First quadrant(x primed-*,y primed-*)
2840 XP-XPOL
2850 YP-YPOL
2860 GOSUB 3460
2870 'Second quadrant (x primed-*, y primed—)—moving clockwise.
2880 XP-XPOL
2890 YP— YPOL
2900 GOSUB 3460
2910 'Third quadrant (x primed—,y primed—)
2920 XP—XPOL
2930 YP—YPOL
2940 GOSUB 3460
2950 'Fourth quadrant (x primed—,y primed-*)
2960 XP—XPOL
2970 YP-YPOL
2980 GOSUB 3460
2990 'End contour point loop.
3000 NEXT L
158
-------
3010 'End contour loop.
3020 NEXT J
3030 XSHCF-SCRCX+(XHTOPF-XC)*DSCRXDDD
3040 YSHCF-SCRCY-(YHTOPF-YC)*DSCRYDDD
3050 XUL-XSHCF-1
3060 XLR-XSHCF+1
3070 YUL-YSHCF-1
3080 YLR-YSHCF+1
3090 'Plot a 3x3 box of points centered about the cutoff hill centroid.
3100 LINE (XUL,YUL)-(XLR,YLR)»IC,BF
3110 PRINT HNAME2$ " ECRIT-" HC
3120 'Pause until user strikes a key. If the ESC key is pressed, then
3130 'execution of the program is terminated.
3140 GOSUB 3410
3150 CLS
3160 'End loop on critical elevations.
3170 NEXT I
3180 SYSTEM
3190 IP ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUND-Press any key"
3200 GOSUB 3410
3210 SYSTEM
3220 17 ERR-53 THEN PRINT "HCRIT PLOT FILE NOT FODND-Press any key"
3230 GOSUB 3410
3240 SYSTEM
3250 PRINT "FITCON AND HCRIT RILL IDs DO NOT MATCH-Press any key"
3260 GOSUB 3410
3270 SYSTEM
3280 PRINT "FITCON AND HCRIT HILL NAMES DO NOT MATCH-Press any key"
3290 GOSUB 3410
3300 SYSTEM
3310 PRINT "FITCON AND HCRIT NUMBER OF CONTOURS DO NOT MATCH-Press any key"
3320 GOSUB 3410
3330 SYSTEM
3340 PRINT "FITCON AND 'HCRIT CONTOUR IDs DO NOT MATCH-Press any key"
3350 GOSUB 3410
3360 SYSTEM
3370 END
3380 'Subroutine which causes program execution to pause until a key
3390 'is struck. If the ESC key is pressed, then program execution
3400 'will be terminated.
3410 A$-INKEY$: 17 A$-"« THEN 3410
3420 17 A$-CHR$(27) THEN SYSTEM
3430 RETURN
3440 'Subroutine to rotate points into the xfy coordinate system before
3450 'plotting
3460 X7IT-XHTOP7+XP*CSE-YP*SNE
3470 Y7IT-YHTOP7+XP*SNE+YP*CSE
3480 XS-SCRCX+(XFIT-XC)*DSCRXDDD
3490 YS-SCRCY-(Y7IT-YC)*DSCRYDDD
3500 PSET(XS^YS),IC
3510 RETURN
159
-------
HPLTCOH
160
-------
10 'Program to plot contours for actual and fitted hills on a display
20 'terminal with 720(horizontal)x348(vertical) resolution(black and
30 'white) driven by a Hercules Graphics Board
40 'Clear the screen.
50 CLS
60 'Disable the display of function keys to allow more space for
70 'plotting.
80 KEY OFF
90 DEFINT I-N
100 'Dimension the arrays for contour elevations, contour identification
110 *numbers(from both FITCON and HCR1T), and the array for storing the
120 'plot of digitized contours(unedited or edited).
130 DIM HCOH(200),IDC1(200),IDC2(200),IAR(15662)
140 LOCATE 12,15
150 'Input the name of the plotfile from program FITCON
160 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM FITCON—>";PLOT1$
170 ON ERROR GOTO 2940
180 OPEN PLOT1$ FOR INPUT AS 11
190 ON ERROR GOTO 0
200 INPUT!1, PF1$
210 IF PF1$-"FITCON" THEN GOTO 270
220 CLS
230 LOCATE 10,15
240 PRINT PLOT1$ " IS NOT A FILE GENERATED BY PROGRAM FITCON-TRY AGAIN"
250 CLOSE f-1
260 GOTO 140
270 CLS
280 'Input the hill identification number, hill name, hill center
290 'coordinates, number of fitted contours, and the identification
300 'for the fitted contours.
310 INPUT*1, IDH1,HNAME1$
320 INPUT*1, XHTOP,YHTOP
330 INPUT*1, NCI
340 FOR J-l TO NCI
350 INPUT*1,IDC1(J)
360 NEXT J
370 'Input the plot boundaries for the unedited contours.
380 INPUT*!, XMIN1,XMAX1,YMIN1,YMAX1
390 'Input the plot boundaries for the edited contours.
400 INPUT*!, XMIN2,XMAX2,YMIN2,YMAX2
410 'Set plot boundaries and scale factors.
420 SCRCX-3601:DSCRX-499!:SCRCY-180!:DSCRY-333I:RATIO-1.4286
430 CLS
440 LOCATE 10,22
450 'Select the type of contours to be displayed.
460 PRINT "SELECT THE CONTOUR TYPE FOR DISPLAY"
470 PRINT
480 PRINT TAB(22) "1.) Unedited Contours"
490 PRINT TAB(22) "2.) Edited Contours"
500 PRINT
510 INPUT " . Choice?(1 or 2)—>";DFLAG%
520 CLS
530 IF DFLAG*»2 THEN GOTO 590
540 XO(XMIN1+XMAX1)/21
550 YO(YMINl+YMAXl)/2!
560 DX-XMAX1-XMIN1
570 DY-YMAX1-YMIN1
580 GOTO 630
590 XO(XMIN2+XMAX2)/2!
600 YO(YMIN2+YMAX2)/2!
161
-------
610 DX-XMAX2-XMIN2
620 DY-YMAX2-YMIN2
630 IF DX/DY-2 AND ABS(X-X1)<1E-15 AND ABS(Y-Y1)<1E-15 THEN GOTO 1170
980 'Scale the point x,y for plotting.
990 XS-SCRCX+(X-XC)*DSCRXDDD
1000 YS-SCRCY-(Y-YC)*DSCRYDDD
1010 IF DUPFLG%-0 GOTO 1130
1020 'One of the multiple contours has been closed. Move to the new point
1030 'without drawing a line. Substitute the current point for the
1040 'previous individual contour beginning point.
1050 XOLD-X
1060 YOLD-Y
1070 DUPFLG%-0
1080 PSET(XS,YS)
1090 GOTO 1170
1100 'Determine whether one of the individual multiple contours has been
1110 'closed. If so, set the closure indicator DUPFLG% to 1 and
1120 'increment the contour closure counter IFR by 1.
1130 IF ABS(X-XOLD)<1E-15 AND ABS(Y-YOLD)<1E-15 THEN DUPFLG%-1:IFR«IFR+1
1140 'Draw a line from the previous point to the current point.
1150 LINE -(XS,YS)
1160 'End loop over contour points.
1170 NEXT K
1180 IF DFIAG*01 THEN GOTO 1250
1190 'Skip over edited contours.
1200 INPUTfl,NPC
162
-------
121C FOR K-l TO NPC
1220 INPUT!1 DUMX,DUMY
1230 NEXT K
1240 'End loop over contours.
1250 NEXT J
1260 'Scale hill center coordinates.
1270 XSHC-SCRCX+ (XHTOP-XC) *DSCRXODD
1280 YSHOSCRCY- (YHTOP-YC) *DSCRYDDD
1290 XUL-XSHC-1
1300 XLR-XSHC+1
1310 YUL-YSHC-1
1320 YLR-YSHC-P1
1330 'Plot a 3x3 box of points centered at the hill center.
1340 LZNE(XUL,YUL)-(XLR,¥LR),,BF
1350 'Store the plot of digitized contours in array IAR.
1360 GET (0,0)-(719,347),IAR
1370 PRINT HNAME1$ " INPUT CONTOURS"
1380 'Pause until user presses a key. Program will terminate if the
1390 'user presses the ESC key.
1400 GOSUB 3160
1410 CLS ' .
1420 'Restore the plot of digitized contours.
1430 PUT (0,0),IAR,PSET
1440 'Begin loop over contours.
1450 FOR J-l TO NCI
1460 'Input ellipse parameters for each contour: ellipse centreid
1470 'coordinates, semi-axes lengths, and the orientation of the minor
1480 'axis with respect to the positive x-axis.
1490 INPUT*1, XCM,YCM,A,B,OR£N
1500 'Determine the orientation.of the ellipse major axis with respect
1510 'to the positive x-axis.
1520 OREN-OREN-901
1530 CSE-COS(.017453*OREN)
1540 SNE-SIN<.Or7453*OR£N)
1550 XP-A
1560 XFIT-XCM+XP*CSZ
1570 YFIT-YCM+XP*SNE
1580 XS-SCRCX+(XFXT-XC)*DSCRXDDD
1590 YS«SCRCY-(YFIT-YC)*DSCRYDDD
1600 'Move to a point at the end of the ellipse semi-major axis.
1610 PSET(XS,YS)
1620 A2-AA2
1630 B2»BA2
1640 'Draw an ellipse with 120 points.
1650 FOR L-l TO 120
1660 THC—L*. 05276
1670 R-SQR(li/(COS(THC)A2/A2+SIN(THC)*2/B2))
1680 XP-R*COS(THC)
1690 YP-R*SIN(THC)
1700 XFIT-XCM+XF*CSE-YI>*SNE
1710 YFIT-YCK+XP*Sl!E+YP*CS£
1720 XS-SCRCX-l-(X7IT-XC)*DSCRXDDD
1730 YS-SCRCY-(YFIT-YC)*DSCRYDDD
1740 LINE -(XS,YS)
1750 NEXT L
1760 'End loop over contours.
1770 NEXT J
1780 PRINT HNAME1$ " FITTED CONTOURS"
1790 'Pause until the user presses a key. If the user presses the ESC
1800 'key, then program execution will terminate.
163
-------
1810 GOSUB 3160
1820 CLS
1830 'Begin plotting contours for fitted cutoff hills.
1840 LOCATE 12,19
1850 'Determine whether fitted hill contours are to be displayed..
1860 INPUT " DISPLAY PITTED CUTOFF HILL CONTOURS?(Y/N)->";ANS$
1870 IF ANS$-"N" THEN SYSTEM
1880 IF ANS$-"n" THEN SYSTEM •
1890 CLOSE fl
1900, LOCATE 14,20
1910 'Input the name of the plot file from program HCRIT.
1920 INPUT " INPUT NAME OF PLOTFILE FROM PROGRAM HCRIT";PLOT2$
1930 ON ERROR GOTO 2970
1940 OPEN PLOT2S FOR INPUT AS II
1950 ON ERROR GOTO 0
1960 'Make sure that the plot file was generated by program HCRIT.
1970 INPUTfl, PF2$
1980 IF PF2$-"HCRIT" THEN GOTO 2040
1990 CLS
2000 LOCATE 12,15
2010 PRINT PLOT2$ " IS NOT A FILE GENERATED BY PROGRAM HCRIT-TRY AGAIN"
2020 CLOSE fl
2030 GOTO 1900
2040 CLS
2050 'Check whether the hill identification number, hill name, number
2060 'of fitted contours, and contour identification numbers match.
2070 INPUTfl, IDH2,HNAME2$
2080 IF IDH20IDH1 THEN GOTO 3000
2090 IF HNAMB1$<>HNAME2$ THEN GOTO 3030
2100 INPUTfl, NC2
2110 IF NC10NC2 THEN GOTO 3060
2120 FOR J-l TO NC2
2130 INPUTfl, IDC2(J)
2140 IF IDC1(J)OIDC2(J) THEN GOTO 3090
2150 NEXT J
2160 'Input hill top elevation and contour elevations.
2170 INPUTfl, HTOP
2180 FOR J-l TO NC2
2190 INPUTfl, HCON(J)
2200 NEXT J
2210 'Input the number of critical elevations.
2220 INPUTfl, NCR
2230 'Begin loop for critical elevations.
2240 FOR 1-1 TO NCR
2250 'For each critical elevation, input the critical elevation, cutoff
2260 'hill centroid coordinates, orientation of the hill minor axis
2270 'with respect to the positive x-axis, and the inverse polynomial
2280 'fit parameters for each hill axis.
2290 INPUTfl, HC,XHTOPF,YHTOPF,ORENF,PA,PB>RLA,RLB
2300 'Determine the orientation of the major axis with respect to the
2310 'positive x-axis.
2320 ORENF-ORENF-90!
2330 CSE-COS(.017453*OR£NF)
2340 SNE-SIN(.017453*ORENF)
2350 'Retrieve the background plot of digitized contours(unedited or edited)
2360 PUT (0,0),IAR,PSET
2370 'Begin loop over contours.
2380 FOR J-l TO NC2
2390 'Contours must be at least one elevation unit higher than the
2400 'critical elevation if their elevations are to be used for the display
164
-------
2410 'of contours on the cutoff hill.
2420 IF HCON(J)<-HC-H! THEN GOTO 2770
2430 FLOG-LOG((HTOP-HC)/(HCON(J)-HC)-1!)
2440 AFIT-RIA*£XP((1!/PA)*FLOG)
2450 BFIT-RLB*£XP((1!/PB)*FLOG)
2460 'The aquation for the inverse polynomial contour is
2470 • (XP/AFIT)**PA+(YP/BFIT)**PB-1
2480 'in the coordinate system in which the x and y primed axes
2490 'coincide with the major and minor axes of the hill respectively.
2500 'Begin loop to calculate 800 contour point coordinates.
2510 FOR XXL TO 200
2520 IF L>99 GOTO 2580
2530 'Let x primed be the independent variable.
2540 XPOL-L*.01*AFIT
2550 YPOL-BFIT*(1!-(XPOI/AFIT)APA)A(1!/PB)
2560 GOTO 2610
2570 'Let y primed b« the independent variable.
2580 YPOL-(L-100)*.01*BFIT
2590 XPOL-AFIT*(11-(YPOL/BFIT)APB)A(1!/PA)
2600 'First quadrant(x primed-*,y primed—t-)
2610 XP-XPOL
2620 YP-YPOL
2630 GOSUB 3210
2640 'Second quadrant (x primed—t-,y primed—)--moving, clockwise
2650 XP-XPOL
2660 YP—YPOL
2670 GOSUB 3210
2680 'Third quadrant (x primed— ,y primed—)
2690 XP—XPOL
2700 YP—YPOL
2710 GOSUB 3210
2720 'Fourth quadrant (x primed— ,y primed—t-)
2730 XP—XPOL
2740 YP-YPOL
2750 GOSUB 3210
2760 NEXT L
2770 NEXT J
2780 XSHCF-SCRCX+(XHTOPF-XC)*DSCRXDDD
2790 YSHCF-SCRCY-(YHTOPF-YC)*DSCRYDDD
2800 XUL-XSHCF-1
2810 XLR-XSHCF+1
2820 YUL-YSHCF-1
2830 YLR-YSHCF+1
2840 'Plot a 3x3 box of points centered about the cutoff hill centroid.
2850 LINE (XUL,YUL)-(XLR,YLR),,BF
2860 PRINT HNAME2$ " ECRIT-" HC
2870 'Pause until the user strikes a key. If the ESC key is pressed, then
2880 'execution of the program is terminated.
2890 GOSUB 3160
2900 CLS '
2910 'End loop on critical elevations.
2920 NEXT I
2930 SYSTEM
2940 IF ERR-53 THEN PRINT "FITCON PLOT FILE NOT FOUNO-Press any key"
2950 GOSUB 3160
2960 SYSTEM
2970 IF ERR-53 THEN PRINT "HCRIT PLOT FILE NOT FOUND-Press any key"
2980 GOSUB 3160
2990 SYSTEM
3000 PRINT "FITCON AND HCRIT HILL IDs DO NOT MATCH-Press any key"
165
-------
3010 GOSUB 3160
3020 SYSTEM
3030 PRINT "FITCON AND HCRIT HILL NAMES DO NOT MATCH-Press any key"
3040 -GOSUB 3160
3050 SYSTEM
3060 PRINT "FITCON AND HCRIT NUMBER OF CONTOURS DO NOT MATCH-Press any key"
3070 GOSUB 3160
3080 SYSTEM
3090 PRINT "FITCON AND HCRIT CONTOUR IDs DO NOT MATCH-Press any key"
3100 GOSUB 3160
3110 SYSTEM
3120 END
3130 'Subroutine which causes program execution to pause until a key
3140 'is struck. If the ESC key is pressed, then program execution
3150 'will be terminated..
3160 A$-INKEYS: IF A$-"" THEN 3160
3170 IF AS-CHR$(27) THEN SYSTEM
3180 RETURN
3190 'Subroutine to rotate points into the x,y coordinate system before
3200 'plotting
3210 XFIT-XHTOPF+XP*CSE-YP*SNE
3220 YFIT-YHTOPF+XP*SNE+YP*CSE
3230 XS-SCROC+(XFIT-XC)*DSCRXDDD
3240 YS-SCRCY-(YFIT-YC)*DSCRYDDD
3250 PSET(XS,YS)
3260 RETURN
166
-------