NOAA Technical Report NOS CS 5

MECCA2 PROGRAM DOCUMENTATION

Silver Spring, Maryland

January 2000

noaa National Oceanic and Atmospheric Administration

U.S. DEPARTMENT OF COMMERCE

National Ocean Service

Coast Survey Development Laboratory
Office of Coast Survey

National Ocean Service

National Oceanic and Atmospheric Administration

U.S. Department of Commerce

The Office of Coast Survey (CS) is the Nation’s only official chartmaker. As the oldest United States scientific

organization, dating from 1807, this office has a long history. Today it promotes safe navigation by

managing the National Oceanic and Atmospheric Administration’s (NOAA) nautical chart and

oceanographic data collection and information programs.

There are four components of CS:

The Coast Survey Development Laboratory develops new and efficient techniques to accomplish

Coast Survey missions and to produce new and improved products and services for the maritime

community and other coastal users.

The Marine Chart Division collects marine navigational data to construct and maintain nautical

charts, Coast Pilots, and related marine products for the United States.

The Hydrographic Surveys Division directs programs for ship and shore-based hydrographic survey

units and conducts general hydrographic survey operations.

The Navigation Services Division is the focal point for Coast Survey customer service activities,

concentrating predominantly on charting issues, fast-response hydrographic surveys and Coast Pilot

updates.
NOAA Technical Report NOS CS 5

MECCA2 PROGRAM DOCUMENTATION

Kurt Hess

January 2000

noaa National Oceanic and Atmospheric Administration

U.S. DEPARTMENT National Oceanic and National Ocean Service

OF COMMERCE Atmospheric Administration Nancy Foster

William Daly, Secretary D. James Baker, Under Secretary Assistant Administrator

Office of Coast Survey Coast Survey Development 

Captain David MacFarland Laboratory

Bruce Parker
NOTICE

Mention of a commercial company or product does not constitute an

endorsement by NOAA. Use for publicity or advertising purposes of

information from this publication concerning proprietary products or the

tests of such products is not authorized.
iii

TABLE OF CONTENTS

LIST OF FIGURES ............................................................ iv

1. INTRODUCTION ............................................................ 1

2. MODEL ATTRIBUTES ....................................................... 3

Numerical Code .......................................................... 3

Model Variables .......................................................... 3

Model Grid .............................................................. 4

Cell Attribute Codes ...................................................... 5

Atmospheric Heat Flux .................................................... 7

Input and Output Files ..................................................... 7

3. IMPROVEMENTS ........................................................... 9

Corrections to Previous Version ............................................. 9

Input Data Files .......................................................... 9

Ocean and River Boundaries ............................................... 12

Vertical and Horizontal Diffusivity .......................................... 13

Shallow Water Wind Stress Reduction ....................................... 14

Internal-Mode Velocity Boundary Conditions .................................. 14

Density Function and Gradients ............................................. 16

Output for Graphing ...................................................... 16

Non-linear Horizontal Advection ........................................... 16

4. ACKNOWLEDGMENTS ..................................................... 18

5. REFERENCES ............................................................. 19

APPENDIX A. ERRATA SHEET ................................................. 21

APPENDIX B. SAMPLE GEOGRAPHY FILE ...................................... 23

APPENDIX C. SAMPLE CONTROL FILE ......................................... 27

APPENDIX D. CODE LISTING .................................................. 29
iv

LIST OF FIGURES

Figure 2.1. Plan View and Isometric View of grid cells showing placement of variables. ...... 4

Figure 2.2. Chesapeake Bay model grid showing water cells. ............................ 6

Figure 3.1. Wind vectors over the Chesapeake Bay grid ............................... 11

Figure 3.2. Instantaneous surface currents around Rattray Island, Australia.. ............... 17
1. INTRODUCTION

This report describes the latest version of the MECCA (Model for Estuarine and Coastal Circulation

Assessment) code that was originally published by Hess (1989) and hereafter referred to as M1. The

new version of the code was developed in response to demands for a hindcast model for Chesapeake

Bay (Bosley, 1996; Bosley and Hess, 1998), and to a lesser extent, to provide a version which

corrected some of the errors in the first release. The original code is still operable, provided a few

corrections to the code are made as described in the errata sheet (Appendix A).

MECCA was originally developed to meet several shortcomings not found in existing models: (1)

extensive documentation including step-by-step development of the applicable equations and their

conversion into finite difference form; (2) creation of a standardized form for the input that requires

little explanation, can be adapted to most regional applications, and minimizes recoding; (3)

provision of a model with internal switches to selectively eliminate various terms in the equations

for sensitivity purposes; and (4) the inclusion of imbedded, one-dimensional flow to better represent

river and channel flows. This philosophy has not changed.

With the new version comes additional philosophic goals: (1) to provide a basic, streamlined (less

code) version which requires the user to do more outside coding and (2) reading data from similar,

external files to provide time series values for boundary conditions. For example, the new version

reads all data files two records at a time; fewer values are stored at any time, but with linear

interpolation the user needs to add more points in time to create a smooth curve - there is no cubic

interpolation (which requires four time points). Other improvements include variable array sizes,

corrections to the original code, and several other changes (see Section 3). 

The model has been requested, distributed, and used numerous times. The author has completed

several applications including the estimation of Chesapeake Bay's natural period (Hess, 1988a),

sediment transport (Hess, 1988b), and crab larval drift (Johnson and Hess, 1990). It has been used

for the Gulf of Maine (Brooks, 1992; Brooks and Churchill, 1992; Brooks, 1994) and in Australian

coastal waters (Galloway et al., 1996 - but see Section 4; King et al., 1998). It has been applied to

coastal flows in France (Smaoui, 1996; Berthet, 1996).

This report is intended to describe the new features with a short review of the previous version (see

M1 for details). The report covers a brief overview of the model in Section 2, a description of new

features in Section 3, and an overview of applications to Chesapeake Bay and Rattray Island,

Australia, in Section 4. Appendix A contains an errata sheet for the original version of MECCA.

Appendix B has a new sample Geography File and Appendix C has a new sample Control File.

Appendix D contains a listing of the MECCA2 code.
2
3

2. MODEL ATTRIBUTES

The following is a brief discussion of MECCA attributes as discussed in M1 which serves as a

refresher in preparation to the description of the modifications in Section 3.

Numerical Code

TheMECCAcode solves the hydrodynamic equations of momentum, mass, salinity, and temperature

conservation. It is three-dimensional in space, uses a vertical sigma coordinate, has a time-varying

free surface, and incorporates non-linear horizontal momentum advection. It includes a threedimension time variable horizontal diffusion based on Smagorinsky (see Tag et al., 1979) and

includes vertical turbulent diffusion based on a mixing length and Richardson number-dependent

reduction (Munk and Anderson, 1948). For the horizontal momentum equations, the external gravity

wave mode is split apart from the internal mode.

Variables are placed on an Arakawa C-grid with square cells in the horizontal and at uniform

intervals along a sigma-stretched vertical coordinate. External-mode momentum is solved with an

alternating-direction, semi-implicit method in the horizontal. The salinities, temperatures, and

internal-mode velocities are solved with a semi-implicit method in the vertical.

The sigma vertical coordinate is defined here as

 (2.1)

where 0 is water level departure from the reference surface (z = 0) and d is the depth relative to the

reference surface. In recent years, some modelers have encountered certain problems with sigma

coordinate systems (Haney, 1991). Theseproblemsarosefrom accurately representing the horizontal

pressure gradient due to density, and can be overcome by using uniformly-spaced sigma levels and

by subtracting the spatially-averaged density before computing the horizontal gradient. MECCA has

both these features.

The model is coded in Fortran with a modest amount of vectorization. Constants are read in from

a Control File, and basin attributes are stored in a Geography File. Output is saved at the end of the

run to provide a restart capability.

Model Variables

Two-dimensional variables include mean sea level depth (D), water level (SE, SEP, SEPP),

vertically-integrated velocities (UH, UHP, VH, VHP), bottom stress (TBX, TBY), wind (WX, WY),

surface stress (TSX, TSY), vertically-integrated horizontal turbulent viscosity (AH), and velocity

departure functions (THETA1, THETA2, THETA3, THETSU, THETSV), cell status (IFIELD),

time-integrated variables (SOLD, UHOLD, VHOLD), channel width (BX, BY), flow indices

(MFLUX, NFLUX), edge parameter (FEDGE), relative cell area (AREA), vertically-averaged

horizontal diffusivity (AH and AHC), and imbedded channel widths (BX, BY). 
4

Three-dimensional variables include internal mode velocities (U, V, W), vertical viscosity (AV),

vertical diffusivity (DV), salinity (S), temperature (T), Richardson Number (R), and horizontal

viscosity (AH3). All units are metric unless otherwise stated.

Model Grid

Variables in the numerical grid are indexed by M in the x direction, N in the y direction and L in the

-q direction. Placement of variables in grid cells are shown in Figure 2.1.

The positions of cell boundaries in the grid's horizontal plane determined by 

x = N) and y = M), 

 (2.2)

where ) is the grid size in meters. Position in the vertical is determined by 

z = (1-L)*, 

 (2.3)

where * = 1/(LBOT - 1) and LBOT is the number of the level that correspond to the bottom. 

 (a) Plan View (b) Isometric View

Figure 2.1. Plan View (a) and Isometric View (b) of grid cells showing placement of variables. The

Plan View shows the two-dimensional variables. At D there are also SE, AH, FEDGE, AREA, PHI,

WX, WY, IFIELD, FX, FY, TSX, TSY, and SOLD. At UH there are also U, UHOLD, UE, MFLUX,

TBX, BX, GSTARX, THETA1, THETSU. At VH there are also V, VHOLD, VE, NFLUX, TBY,

BY, GSTARY, THETA2, and THETSV. At AC (which is AHC) there is also THETA3. The

Isometric View (b) shows the location of three-dimensional variables. At U there is also GRX and

at V there is also GRY. At S there is also T and AH3. At W there is also AV and DV.
5

The grid is oriented to the surface of the earth by the following variables in the Geography File

(Appendix B): BSNANG, BSNLAT, BSNLON, NCOR, and MCOR. The lower corner (i.e., closest

to the origin) of cell (n = NCOR, m = MCOR) is at latitude BSNLAT and longitude BSNLON. The

lower corner corresponds to location x = (NCOR - 1)) and y = (MCOR - 1)), where ) is the grid

size. The y axis is oriented at an angle BSNANG clockwise from due east. Suppose :x is the

Mercator transform from degrees longitude to X and :y is the Mercator transform from degrees

latitude to Y. Then the Mercator coordinates of any cell's lower corner are

 (2.4)

where

 (2.5)

and )

o

 is the grid size converted to degrees of latitude

 (2.6)

The grid for Chesapeake Bay is shown in Figure 4.2 (Bosley and Hess, 1998; Bosley, 1996).

Simulations are being made on a grid with bathymetry that was previously developed at the U.S.

Naval Academy (Hoff, 1990). The grid cell size ()) is 5,606 m and the model was run in barotropic

mode. 

Cell Attribute Codes

Each cell in the Geography File (Appendix B) is tagged with a two-digit number that defines certain

attributes. The entire status of the cell is stored in the two-dimensional array IFIELD, where

IFIELD = 10(I) + J

 (2.7)

For example, a cell may represent either land or water, and if water it may be an ocean or river

boundary cell. It may also be either a full or half (triangular) cell, although boundary cells must be

full. This is the cell's geographic status, and is coded in the single-digit integer I. For example, 

 

 I = 1 denotes a triangle

 2 denotes a full water cell

 5 denotes an ocean boundary cell

 6 denotes a river boundary cell
6

Figure 2.2. Chesapeake Bay model grid showing water cells. Cells are

5606 m on a side. Upper reaches of rivers are modeled as narrow

channels.
7

A second cell feature is the potential existence of a physical barrier that prevents flow in either or

both directions, and is coded in the single-digit integer J. For example,

 J = 0 denotes no barriers

 1 denotes a barrier in x-direction

 2 denotes a barrier in y-direction

 3 denotes barriers in both the x- and y-directions

The program uses IFIELD primarily to skip over land cells and to enforce zero flux at barriers.

NOTE: because MECCA sometimes makes calculations at cells near the edge of the grid, it is

desirable to have extra rows and columns of non-water cells at the outer boundaries of the grid. 

Atmospheric Heat Flux

The atmospheric heat flux formulation in M1 was tested with data for Tampa Bay (Hess, 1994) and

found to be satisfactory. There are only a few minor changes to the code. Bottom heat flux has been

removed since it had little effect on computed water temperatures.

Input and Output Files

MECCA is tailored for a specific application by reading data from a set of input files. Time step,

printing, and other data, as well as the names of all other input files, are read in from the Control

File. The grid, depths, orientation, and cell size are read from the Geography File. Environmental,

or driving, data are read from additional files (see Section 3). If the run is restarted from a previous

run, an Initialization File is read.

MECCA output is put into another set of files. These are the Screen File, which lists current

timestep, the Print File, which contains top views and side views of various variables, and the

Graphing File, which contains date and time series values at selected locations. A Save File is

created which can be used for an Initialization File.
8
9

3. IMPROVEMENTS

Corrections to Previous Version

The previous version of the code (M1) is still very usable, provided a few corrections, especially one

to the non-linear calculations in the internal-mode module, are made. A table showing the suggested

changes appears in Appendix A. 

Input Data Files

The boundary condition data are now read from separate input files, not from the Control File. In

addition, to reduce array storage requirements, MECCA now stores only two records of data at a

time; values needed in the program are based on a linear interpolation between the two values read

in. 

The following are, in the order they are read in the .CON file, the seven input data file types that can

be read in MECCA:

Ocean Water Levels or Flowrates

Winds or Stresses and (Optional) Pressures Gradients

River Flowrates

Ocean Salinities

Ocean Temperatures

River Temperatures

Additional Meteorological Data

In the .CON file, for each of the above seven types, MECCA reads (1) a text file description (not

used in computation), (2) the number of signals (NSIGS) in the file to be read, and (3) the file name.

If NSIGS is 0, the file name is not read and therefore no data are read (all array values for that

variable are zero).

For all files (except the wind/stress file), each record has a fixed format. A typical record contains

the four-digit year, the day in year, and a number (=NSIGS) of values. The form is

YYYY DDD.DDDD V1 V2 V2 V3 V5

where YYYY is the 4-digit year, DDD.DDDD is a day-in-year date, and V1, V2, etc. are a set of

values corresponding to that time given. Spaces or commas should separate all numbers. For

example, a typical Additional Meteorological Data file is

1994 3.5000 12.04 0.50 0.32 1013.80

 1994 3.6250 13.25 0.56 0.44 1014.10

 1994 3.7500 12.72 0.63 0.30 1014.30

 1994 3.8750 12.03 0.61 0.22 1014.20

 1994 4.0000 10.86 0.59 0.29 1014.20
10

which contains the year, day, air temperature, relative humidity, cloud cover, and air pressure.

The time values are converted to a year-based time, YT, using the universal time coordinate (UT)

and the number of days in the year, D. Note that noon on January 1 corresponds to UT = 1.5.

 (3.1)

Wind data, unlike the other data types which are in ASCII, are stored in a binary file. These data

require two unformatted records per time which contain:

YEAR, UTC, ITYPE1, ITYPE2, ITYPE3, NX, MX

FX, FY, (DPADX, DPADY)

Here YEAR and UTC are the date stamp; ITYPE1, ITYPE2, and ITYPE3 are indices (see below);

and NX and MX are array sizes. The arrays FX(NX, MX) and FY(NX, MX) contain either wind

speeds or wind stresses (per unit water density). DPADX and DPADY are atmospheric pressure

gradients (mb/km). The indices are as follows: for FX and FY containing winds, ITYPE1 = 1; for

FX and FY containing stresses, ITYPE1 = 2. For no atmospheric pressure gradient values to be read,

ITYPE2 = 0; for values to be read, ITYPE2 = 1. For ITYPE3 = 0, model coordinate directions are

used for winds, stresses, and pressure gradients. For ITYPE3 = 1, earth coordinate directions (east,

north) are used.

For a wind with eastward and northward components WE and WN respectively, the components can

be converted to model directions by

(3.2a)

(3.2b)

The components can be converted back to earth coordinates by

(3.3a)

(3.3b)

A sample wind field for Chesapeake Bay is shown in Figure 3.1.
11

Figure 3.1. Wind vectors over the Chesapeake Bay grid. The wind vectors

generated by applying the spatial interpolation scheme to a northeastward wind of

14 m/s at Thomas Point and a southeastward wind of 14 m/s at CBBT. Vectors at

every other cell are plotted.
12

Ocean and River Boundaries

Ocean and river boundaries are defined in a new way. For an ocean boundary, as specified in the

Geography File (Appendix B), the indices are

MB1, MB2, NB1, NB2, ITPO, JTPO, ISET1, ISET2

For an ocean boundary, the cells located at MB1 # M # MB2 and NB1 # N # NB2. The direction

of outflow is set by ITPO, where

 ITPO = 1 denotes flow in +x direction

-1 denotes flow in -x direction

 2 denotes flow in +y direction

-2 denotes flow in -y direction

The type is set in JTPO, where 

JTPO = 1 denotes a water level 

2 denotes a flowrate per unit width. 

3 denotes an Orlanski radiation condition

4 denotes a Riemann invariant condition

The Orlanski (1976) radiation condition is 

 (3.4)

and the Riemann invariant condition (Wurtele et al., 1971) is

 (3.5)

where c is the shallow water wave speed, H is total water depth, and xn is the outward normal

direction.

ISET1 and ISET2 are ocean signal numbers; water level at any cell is linearly interpolated in space

between the present (time-interpolated) value in signal ISET1 at (NB1, MB1) and the value in signal

ISET2 at (NB2, MB2). 

For a river boundary, the indices are

MR1, MR2, NR1, NR2, ITPR, JTPR, ISETR

The direction of inflow, ITPR, is set analogously to ITPO, except that for example +1 means inflow

in the +x direction (not outflow). The type is set in JTPR, where
13

JTPR = 1 denotes simple flowrate

2 denotes water falls 

ISETR is river signal number, so that the first river so defined used signal ISETR in the river

flowrate and temperature files. Also, there is a revised water falls condition. Unlike before (see M1,

p. II-12 to II-15), the boundary water level increment and temperature are introduced directly into

the river cell, not into the adjacent cell.

Ocean boundaries may have one or more of the following variables assigned as a boundary

condition: water level, salinity, and temperature. River boundaries may have one or more of the

following variables assigned as a boundary condition: flowrate, salinity, and temperature.

Vertical and Horizontal Diffusivity

Vertical mixing is handled in a more complex way and allows for negative Richardson Number (R)

values. Negative values occur when the density is unstably stratified, and the new scheme causes

large vertical diffusivities. The approach is based on that of Munk and Anderson (1948). As before,

viscosity and diffusivity are related to a potential, Az as follows:

 (3.6)

 (3.7)

 (3.8)

where 6 is von Karman's constant, Avo and Dvo are small (molecular scale) values, and the functions

fA and fD adjust for stratification. 

Negative values of R, which imply denser water lying above lighter water, now create augmented

mixing. For vertical momentum viscosity

 (3.9)

And for vertical diffusivity,

(3.10)
14

Also, the values of R are bounded:

(3.11)

The 13 mixing variables (Avo, Dvo, Rmin, Rmax, C0 - C8) are coded as (AV0, DV0, RIMIN, RIMAX,

CR0, CRICH(1) - CRICH(8)) and have the nominal values (0.00001, 0.000005, -0.05, 1000., 1.0,

0.4, 10.0, 0.5, 20000., 0.1, 3.33, 1.5, 20000.). There is now no subroutine MIXUP, which (in M1)

created a neutral density distribution.

Horizontal diffusivity has been improved by making it three dimensional. Horizontal diffusivity is

the product of the input parameter DHDA and the viscosity, AH3.

Shallow Water Wind Stress Reduction

Wind stress is reduced in shallow water to avoid high velocities. In the code, wind stress is now

multiplied by the factor fJ, where

(3.12)

and H is the total water depth. The values (d1, d2) are coded as (DTAU1, DTAU2) and have values

(0.10, 1.0).

Internal-Mode Velocity Boundary Conditions

There is a new upper boundary condition on internal-mode velocity. At the upper surface, a onesided approximation may be used by setting ITOPV=3. In that case, horizontal velocity is computed

by setting the upper surface's vertical diffusion and advection to zero and reducing volume-related

terms by half (as is done for the upper salinity and temperature boundary conditions: see M1, p I-77).

In the new version of MECCA, the bottom stress per unit density is defined as the product of a

friction factor and a representative velocity by the generalized form

(3.13)

where M is the friction factor, U is the external-mode velocity, and u is the internal-mode velocity.

For the general case,

(3.14)
15

and ( = 1.

A new feature is the specification of a bottom logarithmic boundary layer with velocity

(3.15)

The roughness height zo is defined in the bottom stress subroutine as 0.003 m. At mid-depth in the

bottom layer (which is at a distance of H*/2 above the bottom), we set the boundary layer velocity

to be equal to the mean of the lowest two sigma level velocities. Squaring each side and rearranging

gives 

 (3.16)

Therefore, M is determined to be

(3.17)

and ( = 0.5. The log-layer bottom boundary condition is activated by setting IBOTV=3.

Another bottom condition, which was included in the older version of MECCA, is one of no slip,

or

(3.18)

In this case, the bottom stress is set equal to the product of the viscosity at the mid-level of the lowest

layer and the velocity gradient

(3.19)

In the new version, the above expression is recast in the form of (3.13) by setting

(3.20)

and ( = 0. The no slip bottom boundary condition is activated by setting IBOTV=0.
16

Density Function and Gradients

Although there is a function for water density, there is no longer a separate function for difference

in density. As before,

(3.21)

The density difference is now computed directly by the difference in values of FRHO. This allows

other density formulations to be used.

When either salinity or temperature are not being updated (c.f., KONCEN), they are set to their

respective constant default values SAL0 (30 ppt) and TMP0 (10 C). If either salinity or temperature

are being updated and a boundary file is missing, boundary values are set to the respective default

values. This allows the full density equation (3.21) to be used with representative salinity or

temperature values.

Vertical and horizontal density gradients can now be excluded selectively. For ICOUPL=0, both the

vertical and the horizontal gradients are set to zero. For ICOUPL=1, only vertical gradients are

included. For ICOUPL=2, both vertical and horizontal gradients are included. 

Output for Graphing

The output file containing time series of model values at successive times has a new format. The

first value in each record is the year, the second is the Julian day, and subsequent values are the

selected modeled values. This makes them identical to the input data files.

Other attributes of the graphical file are selected by the parameters IGPH, NSTGPH, and IGPHOP

(see Appendix C, Sample Control file). IGPH is the number of variables (as denoted by location L,

N, M and ITYP) to be saved (up to 20). NSTGPH is the interval, in internal-mode time steps, that

data are to be saved. IGHPOP (when set to 0) causes the graphical file header information not to be

printed.

Non-Linear Horizontal Advection

The new code contains the corrected versions of the non-linear horizontal momentum advection

terms in the internal mode calculations. For the terms affected, see Appendix A. These terms are

approximated by upstream differencing as follows:

 (3.22)

The original code was corrected in about 1990 although the older version apparently did not affect
17

Figure 3.2. Instantaneous surface currents around Rattray Island, Australia.

the Gulf of Maine simulations (Brooks, 1992; Brooks and Churchill, 1992; Brooks, 1994).

However, MECCA was used for a model inter-comparison study (Galloway et al., 1996). They

simulated tidal flow around Rattray Island on Australia's east coast in an attempt to reproduce lee

eddies that have been observed. Unfortunately, the authors were not successful in producing eddying

flow with MECCA because they did not obtain a corrected version of the model. Although the

authors were given a updated version of the code and plots showing the lee eddies, this information

arrived too late to in their paper. Nevertheless, MECCA did produce eddies (Figure 3.2) that are

virtually identical to those produced by the other three-dimensional models. 
18

4. ACKNOWLEDGMENTS

The author is indebted to Dr. Thor Aarup, who has been instrumental in modernizing portions of the

code to make it more flexible. He has also assisted greatly in disseminating the code to other

interested parties. Dr. Hassan Smaoui diligently checked the code and provided key corrections in

the velocity calculations. He has also extended the model’s capabilities by introducing a turbulence

closure scheme for the diffusivity. Dr. Kathryn Bosley has also greatly spurred development of the

new version by creating the specific needs of the Chesapeake Area Forecasting Experiment, in

testing the model in a variety of scenarios, and in critically assessing the model’s performance and

assumptions.
19

5. REFERENCES

Berthet, C., 1996: Flow and three-dimensional coastal transport: numerical applications. Ph.D.

thesis, Universite de Joseph Fourier, Grenoble, France (in French).

Bosley, K. T., and K. Hess, 1998: Development of a Experimental Nowcast/forecast System for

Chesapeake Bay Water Levels. Proceedings, 4th International Conference on Estuarine

and Coastal Modeling, Alexandria, VA, October 20-22, 1996. 413 - 426.

Bosley, K. T, 1996: Research aimed at prediction of water levels in the Chesapeake Bay. 

Proceedings, Conference on Coastal Oceanic and Atmospheric Prediction. AMS,

Atlanta, 268 - 271.

Brooks, D. A., 1994: A model study of the buoyancy-driven circulation in the Gulf of Maine,

Journal of Physical Oceanography 24 (11), 2387-2412.

Brooks, D. A., 1992: Tides and tidal power in Passamaquoddy Bay: a numerical simulation.

Continental Shelf Research 12, 675-716.

Brooks, D. A., and L. U. Churchill, 1992: Experiments with a terrain-following hydrodynamic

model for Cobscook Bay in the Gulf of Maine. In: Estuarine and Coastal Modeling

(Spaulding et al., Eds), Am. Soc. Civil Eng., 786 pp.

Galloway, D., E. Wolanski, and B. King, 1996: Modeling eddy formation in coastal waters: a

comparison between modeling capabilities. Proceedings, 3rd International Conference on

Estuarine and Coastal Modeling, 13 - 25.

Haney, R. L., 1991: On the pressure gradient force over steep topography in sigma coordinate ocean

models. Journal of Physical Oceanography, 21, 610 - 619.

Hess, K. W., 1994: Tampa Bay Oceanography Project: Development and Application of the

Numerical Circulation Model. U.S. Department of Commerce, NOAA Technical Report

NOS OES 005. 90 pp.

___, 1989: MECCA Program Documentation. U.S. Department of Commerce, NOAA Technical

Report NESDIS 46. 258 pp.

___, 1988a: Linearized numerical model of constituent tides in Chesapeake Bay.(unpublished

manuscript)

___, 1988b: Lagrangian drift model of suspended sediment transport in Chesapeake Bay,

Proceedings, Understanding the Estuary: Advances in ChesapeakeBayResearch, 352-

368.
20

Hoff, M., 1990: A Chesapeake Bay Circulation Model. US Naval Academy, Annapolis, 26 pp.

Johnson, D. F., and K. W. Hess, 1990: Numerical simulations of blue crab larval dispersal and

recruitment, Bulletin of Marine Science, 46(1), 195-213.

Johnson, D. F., and K. W. Hess , 1990: Numerical simulations of blue crab larval dispersal and

recruitment, Bulletin of Marine Science, 46(1), 195-213.

King, B., S. Spagnol, E. Wolanski, and T. Done, 1997: Modeling the Mighty Burdekin River in

Flood. Proceedings, 4th International Conference on Estuarine and Coastal Modeling,

Alexandria, VA, October 20-22, 1996. 103-115.

Munk, W. H., and E. R. Anderson, 1948: Notes on the theory of the thermocline. Journal of

Marine Research, 7, 276 - 295.

Smaoui, H., 1996: Three-dimensional numerical modeling of hydrodynamics and sediment transport

in the eastern part of the English Channel and the southern part of the North Sea. Ph.D.

thesis, University of Lille, France (in French).

Tag, P. M., F. W. Murray, and L. R. Koenig, 1979: A comparison of several forms of eddy viscosity

parameterization in a two-dimensional cloud model. Journal of Applied Meteorology, 18,

1429 - 1441.

Wu, J., 1980: Wind-stress coefficients over sea surface under neutral conditions - a revisit. Journal

of Physical Oceanography, 10, 727 - 740.

Wurtele, M. G., J. Paegle, and A. Sieleki, 1971: The use of open boundary conditions with the storm

surge equations. Monthly Weather Review, 99, 6, 537 - 544.
21

APPENDIX A. ERRATA SHEET

This section contains some of the errors in the MECCA NESDIS report (Hess, 1989) in both the text

(Part I) and the code (Part III).

Text Errors

_____________________________________________________________________________

No. Page Comments

_____________________________________________________________________________

1. I-20 In Eq. 3.34, there should be no negative sign.

2. I-24 In Eq. 4.16, 1sv should be H1sv

3. I-33 Add the definition for Fn,m (Eq. 4.8)

Fn,m = (Mn,m+1 + Mn,m)/( 2Hn,m ) + $cTHETSUn,m

where Mn,m is evaluated at the cell center by Eq. 4.7 and

 LBOT-1

THETSUn,m = Cdrgws | UEn,m |/( )L BXn,m ) ' [ CIk (1

 k=1 

+ Un,m,k /UEn,m ) | (1 + Un,m,k /UEn,m ) | ]

And UEn,m = sign( UEn,m ) max( | UEn,m |, 0.001)

and CIk = 1/(LBOT - 1)

Add C4A = 2)T/)L

2

Then in Eqs. 5.28 and 5.29, C4 should be replaced by C4A.

4. I-42 Add the definition for Fn,m 

Fn,m = (Mn+1,m + Mn,m)/( 2Hn,m )+ $cTHETSVn,m

where

 LBOT-1

THETSVn,m = Cdrgws | VEn,m |/( )L BYn,m ) ' [ CIk (1 

 k=1

+ Vn,m,k /VEn,m ) | (1 + Vn,m,k /VEn,m ) | ]

And VEn,m = sign( VEn,m ) max( | VEn,m |, 0.001)
22

5. I-43 In Eqs. 6.20 and 6.21, C4 should be replaced by C4A.

6. I-54 In Eq. 8.33, the term BHIn,m (in first line) should be multiplied by 2.

Therefore, Eq. 8.34 should be revised to read: C3 = )T/)L

2

 (also applies to p. I-64,

but text reads correctly)

7. I-55 In Eq. 8.45, the term multiplying $a (first line) should be multiplied by 4.

Therefore, add a new variable: C7A = )T/(4)L)

8. I-56 In first line of Eq. 8.49, replace C7 by C7A.

9. I-63 In Eq. 9.3, 1sv should be H1sv

10. I-65 In first line of Eq. 9.26, replace C7 by C7A.

_____________________________________________________________________________

Program Errors

_____________________________________________________________________________

No. Page Comments

_____________________________________________________________________________

1. III-70 Line 325, add CX9=2.*DT/DL**2. Lines 393, 394: change CX4 to CX9.

III-70 Line 357, change 10. to 0.1/RHOW

III-71 Line 413, the variable should be AHDUYY

III-72 Line 477, change 10. to 0.1/RHOW

III-73 Lines 513 and 515: change CX4 to CX9.

2. Non-linear terms in Subroutine UPVP

III-80 After Line 312, add B8=DTT/(4.*DL)

III-81 Lines 388 and 389, change B7 to B8.

Line 410, change UPM(L,M) to UPM(L,N)

 III-83 Lines 509 and 510, change =HI.. to =B8*HI..

Line 540, change VPMM to VPM.

______________________________________________________________________________
23

APPENDIX B. SAMPLE GEOGRAPHY FILE

Sample MECCA2 Geography File.

 CHESAPEAKE BAY FOR MECCA2.0 TITLE 

 2 0 VERSION, ITEST 

----- GRID PARAMETERS -------------------------------------------

GRID DIMENSIONS 

 35 56 5606.00 NMAX,MMAX,DL 

 GRID ORIENTATION 

 18 3 39.58 -76.14 16.0 38. NCOR,MCOR,BSNLAT,BSNLON,BSNANG,REF 

 OCEAN BOUNDARIES 

 1 NUMOBC 49 52 34 34 4 1 1 

 49 52 34 34 2 1 1 1 MB1,MB2,NB1,NB2,ITPO,JTPO,ISET1,ISET2

 RIVER BOUNDARIES 

 9 NUMRIV 

 3 3 18 18 2 2 1 MR1,MR2,NR1,NR2,ITRP,JTRP,ISETR

 11 11 20 20 1 2 2 

 21 21 25 25 -2 2 3

 25 25 28 28 1 2 4

 24 24 15 15 1 2 5

 19 19 8 8 1 2 6

 34 34 12 12 2 2 7

 44 44 17 17 2 2 8 

 50 50 12 12 2 2 9

 ----- CELL STATUS FIELD ----------------------------------------

 (100I2) DATA FORMAT 

 35 5 # COLUMNS/LINE, KOCNBC 

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 012 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0602020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 02120 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 012102013 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 012222013 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0222020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 011202020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0202013 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0111210202012 060 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 01120202020 020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 02020202220 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01122112020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01120 02020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01020122220 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 011202020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 060 0 0 0 0 0 0 010202020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 020 0 0 0 0 0 0 011202022201212 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 01112 0 0 0 0 0 0 0202020202020202060 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 020 0 0 0 0 0 0 011202020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 01013 0 0 0 0 0 0 0 02020202013 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 020 0 0 0 0 0 060 0 020202013 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 01013 0 0 0 0 0 020 0 011202012 0 0 0 0 0 060 0 0 0 0 0 0 0

 0 0 0 0 0 020 0 0 0 0 0 0 0112012 0 0112012 0 0 020 020 0 0 0 0 0 0 0

 0 0 0 0 01013 0 0 0 0 0 0 0 0 0112012 02020222012111220 0 0 0 0 0 0 0

 0 0 0 0 020 0 0 01012 0 0 0 0 0 0 01120202020202020202012 0 0 0 0 0 0

 0 0 0 0 01112 0102220 0 0 0 0 0 0 0 0 01120202020 020202013 0 0 0 0 0

 0 0 0 0 0 0202013 0112012 0 0 0 0 0 0 0 0112020202022202012 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 01120202020202012 012 02020202020202020 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0112020202013202220121120202020 02020 02013 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01120202020202020 02022202020 0 0

 0 0 0 0 0 0 0 0 0 0 06012 0 0 0 0 0 0 011202020202020202020202020 0 0

 0 0 0 0 0 0 0 0 0 0 0 01112 0 0 0 0 0 0 0 0 0 0112020202020202013 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 01112 0 0 0 0 0 0 0 0 0 020202020202020 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0112012 0 0 0 0 0 0 02020202020202020 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01112 0 0 0 0 0 02020202020202013 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 011202012 0 0 011202020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0111212 021202020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 020202020202020202020 0 0 0 0 

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0202020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0222020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0602012 0 0 0 0 0 0 0 020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01112 0 0 0 0 0 0 020202020 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0112012 0 02020222020202012 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01112 0 011202020202020 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01120202020202020202012 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 02020202020202050 0

 0 0 0 0 0 0 0 0 0 0 0602020202020202020222012 0 0 0 011202020202050 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0111320 0 0 0 0 0202020202050 0
24

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 011202012 0 0202020202050 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0112012202211202013 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 011202020 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 010 010 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

---- DEPTH FIELD ----------------------------------------------------- 

 (100I2) DATA FORMAT 

 35 0.01 0.2996 # COLUMNS/LINE, HMSL, CON2M 

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 015 5 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 718 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 41617 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 61519 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61015 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7101215 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0101510 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0161610151810 012 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 9 7172012 015 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01520271720 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01338102030 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01555 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01955 01415 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01545152520 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 010404015 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 8401510 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 8 0 0 0 0 0 0 012327517151518 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 8 8 0 0 0 0 0 0 0307517322021211515 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 032752025 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 0 9 9 0 0 0 0 0 0 0 060351817 6 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 0 010 0 0 0 0 0 0 9 0 033602511 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 0 0 0 0 0 01312 0 0 0 0 0 0 9 0 010307030 0 0 0 0 0 0 8 0 0 0 0 0 0 0

 0 0 0 0 0 013 0 0 0 0 0 0 0 91515 0 0457510 0 0 0 3 0 9 0 0 0 0 0 0 0

 0 0 0 0 01111 0 0 0 0 0 0 0 0 0202325 03570 5 8 5 9 914 0 0 0 0 0 0 0

 0 0 0 0 012 0 0 0 7 8 0 0 0 0 0 0 04035337060 92015101511 0 0 0 0 0 0

 0 0 0 0 0 712 0 81818 0 0 0 0 0 0 0 0 02438803825 0 924 7 5 0 0 0 0 0

 0 0 0 0 0 0121318 02021 6 0 0 0 0 0 0 0 030428535 8 3322510 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 01622221616223032 021 0195020 9 3121316 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0152020202219353526161942502311 01130 0 7 4 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 03535404145502615 03710 610 4 0 0

 0 0 0 0 0 0 0 0 0 0 0 7 7 0 0 0 0 0 0 0202835354550251040301014 9 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 8 8 0 0 0 0 0 0 0 0 0 020555020 850 73012 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 610 0 0 0 0 0 0 0 0 0 045452815501230 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0121216 0 0 0 0 0 0 01040252825203021 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01620 0 0 0 0 0 0 738323835321816 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 021212124 0 0 0 9354050383115 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0262618 010303344404220 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 030303030303138385025 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 82233375228 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0131022375622 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0101010 0 0 0 0 0 0 0 015355035 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01010 0 0 0 0 0 0 020355035 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0131515 0 01018111540454016 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 6 0 0 8162326354012 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 01920283030152832272824 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 015 8163034252025 0

 0 0 0 0 0 0 0 0 0 0 0 7 7 7 7 7 7 8 9 9101313 0 0 0 0 4 92229402724 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0121213 0 0 0 0 0101920253025 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0101013 4 0 0151728293260 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0152035171517101017 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4111413 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 9 0 0 0 0 0 0

 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

 ----- CHANNEL WIDTH DATA --------------------------------------------

 41 NUMBXY 

 3 18 1.00 0.20 0.20 M,N,BX,BY,AREA (SUSQUEHANNA RI.) 

 11 20 0.20 1.00 0.20 M,N,BX,BY,AREA (CHESTER RI.)

 21 25 0.20 1.00 0.20 (CHOPTANK) 

 21 24 0.25 1.00 0.25

 19 8 1.00 0.20 0.20 (POTOMAC) 

 20 8 1.00 0.20 0.20

 21 8 0.20 0.20 0.20

 21 9 0.20 0.20 0.20

 22 8 1.00 0.22 0.22

 23 8 0.22 0.22 0.22

 23 9 0.22 0.22 0.22

 24 8 1.00 0.25 0.25

 24 15 1.00 0.20 0.20 (PATUXENT) 

 25 15 1.00 0.20 0.20

 26 15 0.20 0.20 0.20
25

 26 16 0.20 1.00 0.20

 25 28 1.00 0.15 0.15 (NANTICOKE)

 26 28 1.00 0.15 0.15

 27 28 1.00 0.15 0.15 

 34 12 0.20 1.00 0.20 (RAPPAHANNOCK) 

 34 13 0.20 0.20 0.20

 35 13 0.20 0.20 0.20

 35 14 0.20 0.20 0.20

 36 14 0.22 0.22 0.22

 36 15 0.22 0.22 0.22

 37 15 0.24 0.24 0.24

 37 16 0.25 1.00 0.25

 44 17 0.20 1.00 0.20 (YORK) 

 44 18 0.20 1.00 0.20

 44 19 0.22 0.22 0.22

 45 19 0.22 0.22 0.22

 45 20 0.24 0.24 0.24

 46 20 0.25 0.25 0.25

 50 12 0.18 1.00 0.18 (JAMES) 

 50 13 0.19 1.00 0.19 

 50 14 0.20 1.00 0.20

 50 15 0.21 1.00 0.21

 50 16 0.22 1.00 0.22

 50 17 0.23 1.00 0.23

 50 18 0.24 1.00 0.24

 50 19 0.25 1.00 0.25 

 ----- END OF FILE ----------------------------------------------
26
27

APPENDIX C. SAMPLE CONTROL FILE

MECCA2 Control File. Asterisks in rightmost column denote lines that differ from the original

version.

MECCA VERSION 2.0 Public Release Version

fullbay20.geo NAME OF GEOGRAPHY FILE 

 0 1 1 FILE VERSION,ITEST,KTEST * 

 ----- MODEL CONFIGURATION PARAMETERS ---------------------------------- 

 RUN PARAMETERS 

 240.0 24.00 0.0 24. HRMAX,HROUT,HROUT0,HRSAVE * 

 TIMESTEP(external), SPLIT, NUMBER OF LAYERS

 225.00 4 9 DTE,ISPLIT,LAYRS 

 TURBULENCE VARIABLES 

 1.0 1.0 .01 1.0 -.05 1.E+3 AH00,AH0,CAH,DHAH,RIMIN,RIMAX*

 .003 .000010 .40 10.00 0.5 2.E+4 AV00,AV0,CRICH(1 - 4) *

 .001 .000005 .10 3.33 1.5 2.E+4 DV00,DV0,CRICH(5 - 8) *

 1 1 1.0 IHVISC,IVISC,CR0 *

 DRAG COEFFICIENTS 

 .0007 .0000 .000 .0008 .000065 CDWB1,CDWB2,CDRWS,CDRG1,CDRG2

 HEATING CONSTANTS

 0.10 6.0 ALB,D10PCT *

 SWITCHES 

 1 1 1 1 ICOR,IBETAA,IBETAP,IBETAH 

 1 0 0 0 IEXTRN,INTER,KONCEN,ICOUPL 

 3 2 0 0 ITOPV,IBOTV,IHEAT,ICPOS *

 ----- PRINT PARAMETERS------------------------------------------------- 

 PLAN VIEW VARIABLES (s=surface, b=bottom)

 1 0 0 0 0 0 0 0 0 0 0 0 0 SE,UE,VE,Us,Vs,Ss,Sb,Ts,Tb,AH,AV,Wx,Wy*

 PAGE FORMATS 

 2 1 KPRNT1(DIGIT,CHAR),2(NEW PG) 

 CELLS WITH PRINT AT ALL LEVELS M*1000+N

 2 

 035026 047022 NPRMN 

 CELLS IN LONGITUDINAL SECTION M*1000+N

 1 ISLICE: JSLICE,MSNS 

 10 006017 019017 020018 023018 026021 028021 030023 031023 035027 038027

 CELLS FOR LATER GRAPHING 

 13 4 0 IGPH,NSTGPH,IGPHOP *

 1 50 34 1 ocean boundary L,M,N,ITYP 

 1 52 32 1 cbbt 

 1 32 18 1 Colonial Beach

 1 11 13 1 baltimore 

 1 33 21 1 lewisetta

 1 48 32 1 kiptopeake 

 1 48 24 1 Glouster Pt 

 1 28 20 1 Solomons 

 1 15 16 1 Annapolis

 1 52 32 7 x-stress # 1 (CBBT)

 1 11 13 7 x-stress # 2 (Thomas Point)

 1 52 32 8

 1 11 13 8

 ----- TIME-VARIABLE BOUNDARY INPUTS------------------------------------ 

 STARTING DATE 

 1994 1 1 00 00 IYEAR,MONTH,IDAY,HOUR,MIN 

=OCEAN WATER LEVELS

 1 *

wl.dat *

=WINDS *

 1 *

wind.dat.binary *

=RIVER FLOWRATES *

 9 *

rv.dat *

=OCEANIC SALINITIES *

10 *

ocean_sal.dat *

=OCEANIC TEMPERATURES *

10 *

ocean_tmp.dat *

=RIVER TEMPERATURES *

 1 *

river_tmp.dat *

=ADDITIONAL MET DATA *

4 *

meto.dat *

=INITIAL CONDITIONS *
28

 0 *

-------- OUTPUT FILE NAMES---------------------------------------------*

FPRINT :m20.prn *

FGRAPH :m20.gph *

FMED :MECMED.DAT *

=====END OF FILE =======================================================
29

APPENDIX D. CODE LISTING

Code listing for program MECCA2. Common blocks appear at the end.

 1 PROGRAM MECCA2 

 2 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

 3 C 

 4 C Model for Estuarine and Coastal Circulation Assessment II 

 5 C 

 6 C PURPOSE - TO RUN A THREE-DIMENSIONAL (X-, Y-, Q-DIRECTION) 

 7 C HYDRO MODEL WITH NON-LINEAR ADVECTIVE TERMS AND 

 8 C VARIABLE DENSITY. USES NUMERICAL SCHEME OF ABBOTT 

 9 C FOR THE EXTERNAL (2-D) MODE, AND ANOTHER SCHEME FOR 

 10 C THE INTERNAL (BAROCLINIC) MODE. INCLUDES THOR 

 11 C AARUP'S VARIABLE ARRAY FEATURES. 

 12 C 

 13 C LOGICAL UNITS USED 

 14 C Generic 

 15 C Unit Name No. Used for Name 

 16 C --------- -- ----------------------- -------- 

 17 C INPUT: LUCON 2 READ CONTROL FILE FCON 

 18 C TO READ GEOGRAPHY FILE FGEO 

 19 C READ INITIAL COND'S FILES FINIT 

 20 C LUKB 5 KEYBOARD - 

 21 C LUTID 21 TIDE BC - 

 22 C LUWND 22 GRIDDED WIND FILES - 

 23 C LURIV 23 RIVER FLOWRATES - 

 24 C LUSAL 24 OCEAN SALINITY BC - 

 25 C LUOCT 25 OCEAN TEMPERATURE BC - 

 26 C LURVT 26 RIVER TEMPERATURES - 

 27 C LUMET 27 AIR PRESS,TMP,HUMIDITY - 

 28 C 

 29 C OUTPUT: ISCR 6 CRT SCREEN - 

 30 C IO 10 LINE PRINTER FPRINT 

 31 C LUGRF 11 DATA AT GRAPH POINTS FGRAPH 

 32 C LUMED 12 INTERMEDIATE,FINAL VALUES FMED 

 33 C 

 34 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

 35 C 

 36 C FLOW CHART FOR MAIN PROGRAM 

 37 C 

 38 C MAIN 

 39 C : 

 40 C :------YTIME8 

 41 C :------NYEAR 

 42 C : 

 43 C :------READZ-------ZEROS 

 44 C : RDCON1 

 45 C : RDCON2------JULIAN 

 46 C : RDCON3 IRR 

 47 C : RDWIND 

 48 C : RDGEO-------CHECKS 

 49 C : RDICS 

 50 C : 

 51 C :------INITS-------SETUP-------FLAGS 

 52 C : SETSTP------BSTATE------RR 

 53 C : THETAS 

 54 C : WVERT 

 55 C : 

 56 C :------OUTPUT------PRNCON 

 57 C : PRNBCG 

 58 C : MEDSAV 

 59 C : PGRAPH 

 60 C : PRINTA------PRINTH-------DATES 

 61 C : PRINTX-------PRNCHR 

 62 C <BEGIN LOOP> PRINTI-------GRADP------FRHO 

 63 C : PSLICE 

 64 C : 

 65 C :------FORCES------ATMOS-------RDWIND 

 66 C : BSTRES 

 67 C : ALGRAD 

 68 C : 

 69 C :------EXMODE------THETAS 

 70 C : BNDRY1------RR 

 71 C : HORVIS 

 72 C : UHVH 

 73 C : 

 74 C :------INTRNL------BNDRY2 

 75 C : VERVIS 

 76 C : UPVP--------GRADP-------FRHO 

 77 C : WVERT GETCJ 

 78 C : 

 79 C :------CONCZ-------BNDRY3------BSTATE------RR 

 80 C : BNDRY4 RR 

 81 C : HEAT1 

 82 C : GFLUX-------HEATZ 

 83 C : 

 84 C :------ANALYS 

 85 C : 

 86 C :------OUTPUT------PRNCON 

 87 C : PRNBCG 

 88 C : MEDSAV 

 89 C : PGRAPH 

 90 C : PRINTA------PRINTH-------DATES 

 91 C : PRINTX-------PRNCHR 

 92 C <END LOOP> PRINTI-------GRADP------FRHO 

 93 C : PSLICE 

 94 C (END) 

 95 C 

 96 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

 97 C 

 98 C VARIABLES 

 99 C 

 100 C AG = GRAVITATIONAL ACCELERATION (M/S**2) 

 101 C AH(,) = HORIZONTAL EDDY VISCOSITY (M**2/S) TIMES DEPTH 

 102 C AT GRID CENTER 

 103 C AHC(,) = HORIZONTAL EDDY VISCOSITY (M**2/S) TIMES DEPTH 

 104 C AT GRID CORNER 

 105 C AH3(,,) = 3-D HORIZONTAL EDDY VISCOSITY (M**2/S) TIMES DEPTH

 106 C AT GRID CENTER 

 107 C AHMAX = MAXIMUM ALLOWABLE VALUE FOR AH(,) 

 108 C AH00 = INITIAL VALUE OF HORIZONTAL EDDY VISCOSITY 

 109 C AREA(,) = FRACTION OF AREA OF GRID THAT IS WATER 

 110 C AV(,,) = VERTICAL EDDY VISCOSITY (M**2/S) 

 111 C AV00 = INITIAL VALUE OF VERTICAL EDDY VISCOSITY 

 112 C BSNANG = ANGLE BASIN GRID MUST BE ROTATED CLOCKWISE TO BE 

 113 C CORRECTLY ORIENTED ON EARTH'S SURFACE 

 114 C BSNLAT,BSNLON = NORTH LATITUDE, WEST LONGITUDE OF BASIN GRID POI 

 115 C BX(,),BY(,) = WIDTH FACTOR IN X-, Y-DIRECTION 

 116 C CAW1,CAW2 = AIR-WATER INTERFACIAL DRAG COEFFICIENTS 

 117 C CRICH(1)-CRICH(8) = PARAMETERS IN RICHARDSON NUMBER REDUCTION OF 

 118 C DIFFUSION 

 119 C CWB1,CWB2 = WATER-BOTTOM INTERFACIAL DRAG COEFFICIENTS 

 120 C D(,) = MEAN SEA LEVEL DEPTH (M) 

 121 C DENRAT = RATIO OF AIR DENSITY TO WATER DENSITY 

 122 C DFDM,DFDN = CHANGE IN CORIOLIS PARAMETER PER UNIT CHANGE 

 123 C IN GRID INDEX M, N (TIMES .25*DTE) 

 124 C DHAH = RATIO OF DH(N,M) TO AH(N,M) 

 125 C DHMAX = MAXIMUM ALLOWABLE VALUE FOR DH(,) 

 126 C DL = GRID LENGTH (M) 

 127 C DMAX = MAX. DEPTH IN COMPUTATIONAL REGION 

 128 C DPADX,DPADY = ATMOSPHERIC PRESSURE GRADIENT (MB/KM) 

 129 C DQ = DIMENSIONLESS VERTICAL GRID INTERVAL 

 130 C DTE = TIMESTEP (S) FOR EXTERNAL MODE 

 131 C DTI = TIMESTEP (S) FOR INTERNAL MODE 

 132 C DTEMAX = MAX. TIMESTEP (S) FOR EXTERNAL MODE 

 133 C DTIMAX = MAX. TIMESTEP (S) FOR INTERNAL MODE. UPDATED 

 134 C EACH TIME NEW TURBULENT VISCOSITY IS COMPUTED. 

 135 C DV(,,) = VERTICAL MASS EXCHANGE COEFFICIENT 

 136 C DV00 = INITIAL VALUE OF EDDY DIFFUSIVITY 

 137 C E = SMALL AMOUNT ADDED TO PREVENT ZERO DIVIDE 

 138 C FA( ),FB( ) = RECURSION ARRAYS USED FOR THE IMPLICIT SCHEME 

 139 C FEDGE(,) = EDGE FUNCTION TO RAMP UP FORCES AT OCEAN BOUNDAR 

 140 C GA( ),GB( ) = ARRAYS USED FOR THE IMPLICIT SCHEME 

 141 C HRCONC = TIME (HRS) WHICH MUST ELAPSE BEFORE S, T 

 142 C ARE UPDATED 

 143 C HR = HOURS ELAPSED IN THIS SEGMENT 

 144 C HR0 = ELAPSED TIME (HRS) FROM PREVIOUS RUNS 

 145 C HR1 = TOTAL ELAPSED TIME (HRS) = CUM HOURS 

 146 C IBETAA = INDEX FOR INCLUSION OF NON-LINEAR ADVECTION 

 147 C TERMS: (0 = NO, 1=YES) 

 148 C IBETAH = INDEX FOR NON-LINEAR FINITE-DEPTH TERMS (0=NO, 

 149 C 1=YES) 

 150 C IBETAP = INDEX TO INCLUDE HORIZONTAL PRESSURE GRADIENT 

 151 C DUE TO DENSITY STRUCTURE (0=NO, 1=YES) 

 152 C IBOTV = INDEX FOR BOTTOM BC FOR THE INTERNAL-MODE VEL. 

 153 C 0 = U IS ZERO AT BOTTOM 

 154 C 1 = TAU=1ST-ORDER DU/DZ (DEFAULT WHEN INTER=0) 

 155 C 2 = TAU=2ND-ORDER DU/DZ 

 156 C 3 : AvDU/DZ = TAU log-layer, mid-level 

 157 C ICOUPL = INDEX TO INCLUDE DENSITY VARIATIONS 

 158 C 0 = NO COUPLING 

 159 C 1 = VERTICAL VARIATIONS ONLY (AV,DV) 

 160 C 2 = VERT AND HORIZ (GRAD, GRX, GSTARX) 

 161 C ICPOS = INDEX TO INSURE ZERO OR POSITIVE CONCENTRATIONS: 

 162 C 0 = NO, OTHERWISE = YES 

 163 C ICOL(,),IROW(,) = ARRAYS OF COLUMN AND ROW FLAG NUMBERS 

 164 C ICOR = INDEX FOR CORIOLIS ACCEL (0 OR LESS=NONE, 

 165 C 1=CONSTANT F,2 OR MORE=BETA PLANE APPX.) 

 166 C IEXTRN = INDEX FOR DOING THE EXTERNAL MODE CALCS (0=NO, 

 167 C OTHERWISE YES) 

 168 C IFIELD(,) = INDEX FOR COMPUTATIONAL GRID=IJ 

 169 C I = STATUS:0=LAND,1=HALF FULL,2=FULL,3=WATER 

 170 C LEVEL B.C.,4=RIVER FLOW B.C. 

 171 C J = BARRIER INDEX:0=X & Y FLOW,1=NO X FLOW, 

 172 C 2=NO Y FLOW, 3=NO X, NO Y FLOW. 

 173 C IGPH = NUMBER OF QUANTITIES TO BE GRAPHED 

 174 C IHEAT = INDEX FOR ATMOSPHERIC HEATING: 

 175 C 0=NO HEAT FLUX 

 176 C 1=HEAT FLUX BUT WITH DAY OF YEAR CONSTANT (=NDAY0

 177 C 2=NORMAL HEATING 

 178 C IHVISC = INTERVAL FOR UPDATING HORIZONTAL TURBULENT 

 179 C VISCOSITY (DTE TIMESTEPS) 

 180 C ILFT = INDEX FOR LEFT-MOST BOUNDARY CONDITION: 

 181 C 0 = WATER LEVEL (TIDE OR RADIATION CONDITION) 

 182 C 1 = FLOWRATE (RIVER) 

 183 C 2 = ZERO FLOWRATE (SOLID WALL) 

 184 C INTER = INDEX FOR COMPUTING INTERNAL MODE VARIABLES 

 185 C (0=NO, OTHERWISE = YES) 

 186 C IO = PRINT OUTPUT CHANNEL NUMBER 

 187 C IRGT = INDEX FOR RIGHT-MOST BOUNDARY CONDITION: 

 188 C 0 = WATER LEVEL (TIDE OR RADIATION CONDITION) 

 189 C 1 = FLOWRATE (RIVER) 

 190 C 2 = ZERO FLOWRATE (SOLID WALL) 

 191 C ISCR = CRT SCREEN OUTPUT CHANNEL NUMBER 

 192 C ISPLIT = NO. OF EXTERNAL TIMESTEPS PER INTERNAL TIMESTEP 

 193 C ITOPV = INDEX FOR TOP B.C. FOR INTERNAL MODE VELOCITY 

 194 C (1;TAU=1ST-ORDER DU/DZ, 2:TAU=2ND-ORDER DU/DZ) 

 195 C ITPO() = DIRECTION OF OUTFLOW: 1=X, -1=-X, 2=Y, -2=-Y 

 196 C JTPO() = TYPE OF OCEAN BOUNDARY CONDITION 

 197 C 1 : WATER LEVEL SPECIFICATION 

 198 C 2 : RADIATION OUTFLOW 

 199 C 3 : RADIATION CONDITION, ORLANSKI 

 200 C 4 : RADIATION CONDITION, RIEMANN 

 201 C ITPR() = RIVER DIRECTION TYPE: 1=FLOW IN X, 2=FLOW IN Y 

 202 C (+=FLOW IN POSITIVE DIRECTION, -=FLOW IN NEG. DIR)

 203 C ITYP() = TYPE OF QUANTITY TO BE GRAPHED AT LGPH, MGPH, 

 204 C NGPH: 

 205 C 1 : WATER LEVEL 

 206 C 2 : UE 

 207 C 3 : VE 

 208 C 4 : UE + U 

 209 C 5 : VE + V 

 210 C 6 : W 

 211 C 7 : WIND STRESS IN X DIRECTION 

 212 C 8 : WIND STRESS IN Y DIRECTION 

 213 C 9 : SALINITY 

 214 C 10: TEMPERATURE (CELSIUS) 

 215 C 11: AH3/H 

 216 C 12: THETA1 

 217 C 13: THETA2 

 218 C 14: THETA3 

 219 C 15: AV 

 220 C 16: DV 

 221 C 17: RI 

 222 C 18: WIND IN X DIRECTION 

 223 C 19: WIND IN Y DIRECTION 

 224 C 20: UHOLD/H 
30

 225 C 21: VHOLD/H 

 226 C IVISC = INTERVAL FOR UPDATING VERTICAL TURBULENT 

 227 C VISCOSITY (DTI TIMESTEPS) 

 228 C JPRNT() = INDICES FOR PRINTING OUT THE EXTERNAL FIELDS 

 229 C JTPR() = RIVERINE CONDITION: 1=FLUME, 2=WATER FALLS 

 230 C KONCEN = INDEX FOR UPDATING THE CONCENTRATIONS 

 231 C 0=NO UPDATE, USE S=SAL0, T=TMP0 

 232 C 1=UPDATE ONLY SALINITY, T=TMP0 

 233 C 2=UPDATE ONLY TEMP., S=SAL0 

 234 C 3=UPDATE BOTH SALINITY AND TEMP. 

 235 C KPRNT1,2 = PRINT INDICES: KPRNT1 : 1 PRINTS NUMBERS, 

 236 C 2 PRINTS CHARACTERS IN PRINTX. KPRNT2 : 2 SKIPS 

 237 C TO TOP OF PAGE IN PRINTX, PRINTI 

 238 C L = INDEX FOR VERTICAL LEVELS (1=TOP,LBOT=BOTTOM) 

 239 C LAYRS = NUMBER OF LAYERS (LEVELS=LAYRS+1) 

 240 C LBOT = NUMBER OF LEVELS, OR LEVEL OF BOTTOM (LBOT=LAYRS+1

 241 C M = HORIZONTAL GRID NUMBER IN X DIRECTION 

 242 C MA = FIRST COMPUTATIONAL GRID IN COLUMN 

 243 C MAM = MA - 1, AND NUMBER OF LOWER B.C. GRID 

 244 C N = HORIZONTAL GRID NUMBER IN Y DIRECTION 

 245 C NA = FIRST COMPUTATIONAL GRID IN ROW 

 246 C NAM = NA - 1, AND NUMBER OF LOWER B.C. GRID IN ROW 

 247 C NB = LAST COMPUTATIONAL GRID IN ROW 

 248 C NEGS = NUMBER OF EVENTS WHERE COMPUTED TOTAL WATER 

 249 C DEPTH IN CELLS IS NEGATIVE. WATER DEPTH RESET 

 250 C TO 0.10 M. 

 251 C NSTE = INDEX FOR THE EXTERNAL TIMESTEP 

 252 C NSTET = TOTAL NUMBER OF EXTERNAL TIMESTEPS 

 253 C NSTIT = TOTAL NUMBER OF INTERNAL TIMESTEPS 

 254 C NSTIMX = MAXIMUM NUMBER OF INTERNAL TIMESTEPS 

 255 C NSTEMX = MAXIMUM NUMBER OF EXTERNAL TIMESTEPS PER NSTI 

 256 C OMEGA = EARTH'S ROTATION RATE (RADIANS/S) 

 257 C PHI(,) = EFFECTIVE BOTTOM DRAG COEFFICIENT 

 258 C PI = 3.1415927 

 259 C Q = DIMENSIONLESS VERTICAL VARIABLE (0=TOP, -1=BOT) 

 260 C RATE( ) = RIVER FLOW RATE (M**3/S) 

 261 C RHOW = REFERENCE WATER DENSITY 

 262 C RI(,,) = RICHARDSON NUMBER 

 263 C RICHNO = RICHARDSON NUMBER 

 264 C S(,,) = SALINITY (PPT) 

 265 C SAL0 = DEFAULT SALINITY 

 266 CSE(,),SEP(,),SEPP(,) = INITIAL, UPDATED VALUES OF SEA LEVEL ABOVE MSL 

 267 C SOLD(,) = WATER LEVEL AT START OF INTERNAL TIMESTEP 

 268 C T(,,) = WATER TEMPERATURE (C) 

 269 C TBX(,),TBY(,) = INTERFACIAL WATER-BOTTOM STRESS (M**2/S**2) IN 

 270 C X-, Y-DIRECTION 

 271 C TSX(,),TSY(,) = WIND STRESS PER UNIT WATER DENSITY (M**2/S**2) 

 272 C IN X-, Y-DIRECTION 

 273 C THETA1(,) = (INTEGRAL OF (1 + U(,,)/UE(,))**2 OVER q)*BX*UE 

 274 C THETA2(,) = (INTEGRAL OF (1 + V(,,)/VE(,))**2 OVER q)*BY*VE 

 275 C THETA3(,) = (INTEGRAL OF (1 + U/UE)*(1+V/VE) OVER q)*UE*VE 

 276 C THETSU(,) = INTEGRAL OF (1+U/UE)*ABS(1+U/UE) OVER q 

 277 C THETSV(,) = INTEGRAL OF (1+V/VE)*ABS(1+V/VE) OVER q 

 278 C TMP0 = DEFAULT WATER TEMPERATURE 

 279 C UT = UNIVERSAL TIME COORD (JULIAN TIME) 

 280 C UT0 = JULIAN TIME OF START OF VERY FIRST SEGMENT 

 281 C UT1 = JULIAN TIME OF START OF THIS SEGMENT 

 282 C U(,,) = INTERNAL MODE HORIZONTAL VELOCITY 

 283 C (M/S) IN X-DIRECTION 

 284 C UE(,),VE(,) = EXTERNAL MODE VELOCITY (EXCLUDES VARIABLE WIDTH 

 285 C FACTOR) 

 286 C UH(,),UHP(,) = ORIGINAL, UPDATED HORIZONTAL FLOWRATE (M**2/S) 

 287 C IN X-DIRECTION 

 288 C UHOLD(,),VHOLD(,) = INTEGRATED FLOWRATE OVER INTERNAL-MODE TIMESTEP (M

 289 C V(,,) = INTERNAL MODE HORIZONTAL VELOCITY 

 290 C (M/S) IN Y-DIRECTION 

 291 C VH(,),VHP(,) = ORIGINAL, UPDATED HORIZONTAL FLOWRATE (M**2/S) 

 292 C IN Y-DIRECTION 

 293 C VONKAR = VON KARMAN'S CONSTANT 

 294 C W10 = WIND SPEED AT 10 METERS 

 295 C W(,,) = VERTICAL VELOCITY IN Q-COORDINATE (S**-1) TIMES 

 296 C THE LOCAL TOTAL DEPTH (M/S) 

 297 C WX(,),WY(,) = WIND SPEEDS IN X-, Y-DIRECTION 

 298 C YEAR = PRESENT YEAR AT EACH TIMESTEP 

 299 C YEAR0 = YEAR AT START OF FIRST SEGMENT 

 300 C YEAR1 = YEAR AT START OF THIS SEGMENT 

 301 C 

 302 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

 303 C q(l) 

 304 C PLAN +---------+ Y(n) ELEVATION +-----Ul,n,m--+ 

 305 C VIEW | | VIEW | | 

 306 C | Dn,m Vn,m | Wl,n,m | 

 307 C | | | | 

 308 C +----Un,m-+AHCn,m +---- Ul+1,n,m+ 

 309 C X(m) 

 310 C AT D: SE,AH,AH3,S,T,AV,AREA,FEDGE, AT U: V,AH3,S,T 

 311 C PHI,TSX,TSY,WX,WY,W,SOLD,RI,IFIELD AT W: RI,AV,DV 

 312 C FX,FY,SEP,SEPP 

 313 C AT U: UH,TBX,BX,GSTARX,GRX,UHOLD, 

 314 C UE,THETA1,THETSU,MFLUX,UHP 

 315 C AT V: VH,TBY,BY,GSTARY,GRY,VHOLD, 

 316 C VE,THETA2,THETSV,NFLUX,VHP 

 317 C AT AHC: THETA3 

 318 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

 319 INCLUDE 'COMM20.FOR' 

 320 C SET INTERNAL CONSTANTS 

 321 DATA AG/9.81/,OMEGA/7.29E-5/,VONKAR/.40/,E/1.E-10/,PI/3.1415927/, 

 322 1 SOLAR/1353./,PA/101400./,SB/5.67E-8/,EPSLON/.622/,RHOW/1000./, 

 323 2 CWATER/4186./,RHOA/1.2/,CPAIR/1004./,ALV/2.6E+06/,CDRGWS/0./, 

 324 3 RAD/.0174532927/,NEGS/0/,SAL0,TMP0/30.,10./,NDAYMO/ 

 325 4 31,28,31,30,31,30,31,31,30,31,30,31/,HRCON1,HRCON2/0.,48./, 

 326 5 DTAU1,DTAU2/0.10,1.00/,ITEST/0/,VERS/1.00/,UT00/0.0/ 

 327 C LOGICAL UNIT NUMBERS 

 328 DATA LUCON,LUKB,ISCR/2,5,6/,IO,LUGRF,LUMED/10,11,12/,LUTID, 

 329 1 LUWND,LURIV,LUSAL,LUOCT,LURVT,LUMET/21,22,23,24,25,26,27/ 

 330 C 

 331 C INITIATION PHASE 

 332 C 

 333 C A. READ FILES 

 334 CALL READZ 

 335 C 

 336 C B. SET RUN PARAMETERS 

 337 UT=UT1 

 338 CALL YTIME8(YT,UT,YEAR1) 

 339 CALL INITS 

 340 NSTIMX=HRMAX*3600./DTI+0.5 

 341 IHR=MAX1(1.,3600./DTI) 

 342 C 

 343 C C. PRINT INITIAL VALUES 

 344 CALL OUTPUT 

 345 C 

 346 C ITERATION PHASE 

 347 C 

 348 DO 300 NSTI=1,NSTIMX 

 349 IPRNT1=0 

 350 IF(NSTI.LE.IHR)IPRNT1=1 

 351 IF(MOD(NSTI,2*IHR).EQ.0.AND.NSTI.LT.24*IHR)IPRNT1=1 

 352 IF(MOD(NSTI,12*IHR).EQ.0)IPRNT1=1 

 353 NSTIT=NSTIT+1 ! NSTI+NST0 

 354 DO 150 NSTE=1,ISPLIT 

 355 NSTET=NSTET+1 

 356 c time at end of steps NSTE 

 357 HR=(FLOAT(NSTI-1)*DTI+FLOAT(NSTE)*DTE)/3600. 

 358 HR1=HR+HR0 

 359 CUMDAY=HR1/24. 

 360 UT=UT1+HR/24.-UT00 

 361 CALL NYEAR(UT,YEAR,UT00) 

 362 CALL YTIME8(YT,UT,YEAR) 

 363 IF(NSTI.EQ.1.AND.NSTE.EQ.1)WRITE(ISCR,110)UT 

 364 110 FORMAT(/,X,'BEGIN COMPUTATIONS: UT=',F10.4) 

 365 C 

 366 C D. GET TOP AND BOTTOM STRESSES 

 367 CALL FORCES 

 368 C 

 369 C E. CALCULATE THE EXTERNAL-MODE FLOWRATES AND WATER LEVELS 

 370 IF(IEXTRN.NE.0)CALL EXMODE 

 371 150 CONTINUE 

 372 C 

 373 C F. GET VERTICAL AND HORIZONTAL INTERNAL MODE VELOCITIES 

 374 IF(INTER.NE.0)CALL INTRNL 

 375 C 

 376 C G. UPDATE CONCENTRATIONS 

 377 IF(KONCEN.NE.0)CALL CONCZ 

 378 C 

 379 C H. ANALYZE AND USE RESULTS 

 380 CALL ANALYS 

 381 C 

 382 C I. PRINT OUT VALUES 

 383 IF(MOD(NSTI,IHR).EQ.0)WRITE(ISCR,200)HR,HR1,CUMDAY 

 384 200 FORMAT(5X,'HOURS COMPLETED =',F8.1,' TOTAL HOURS =',F8.1, 

 385 1 5X,'CUM.DAY =',F7.2) 

 386 

 387 CALL OUTPUT 

 388 C 

 389 C LOOK FOR ABNORMAL STOP 

 390 IF(ISTOP.EQ.1)GOTO 320 

 391 300 CONTINUE 

 392 

 393 320 STOP 

 394 END 

 395 C 

 396 c----------------------------------------------------------------------- 

 397 SUBROUTINE NYEAR(UT,YEAR,UT00) 

 398 c increase year if Julian days exceed number in year 

 399 IYEAR=YEAR 

 400 IDAYS=365 

 401 IF(MOD(IYEAR,4).EQ.0.AND.(.NOT.(MOD(IYEAR,100).EQ.0.AND. 

 402 1 MOD(IYEAR,400).NE.0)))IDAYS=366 

 403 IF(IFIX(UT).LE.IDAYS)RETURN 

 404 UT00=UT00+UT-1. 

 405 UT=UT-IDAYS 

 406 YEAR=YEAR+1. 

 407 RETURN 

 408 END 

 409 C 

 410 C======================================================================= 

 411 C MECCA FILE : INITS 

 412 C----------------------------------------------------------------------- 

 413 C 

 414 SUBROUTINE INITS 

 415 C JULY 1985 K. W. HESS MEAD VAX 11/750 

 416 C PURPOSE - TO SET UP INITIAL GRID ARRAYS 

 417 C VARIABLES - 

 418 C ICS = INDEX FOR READ INITIAL CONDITIONS:0=NO, 1=YES 

 419 INCLUDE 'COMM20.FOR' 

 420 C PRINT OUT INITIAL VALUES 

 421 WRITE(ISCR,100)HRMAX,HROUT,HRCONC 

 422 100 FORMAT(5X,'INITS: HRMAX=',F6.1,' HROUT=',F7.2,' HRCONC=',F7.1) 

 423 C INITIALIZE THE ARRAYS 

 424 CALL SETUP 

 425 C INITIALIZE DIAGNOSTIC VARIABLES 

 426 IF(KONCEN.GT.0)CALL SETSTP 

 427 IF(ICS.EQ.1)CALL THETAS 

 428 IF(ICS.EQ.1)CALL WVERT 

 429 RETURN 

 430 END 

 431 C 

 432 C----------------------------------------------------------------------- 

 433 C 

 434 SUBROUTINE FLAGS 

 435 C MAY 1984 K. W. HESS TDL IBM 

 436 C PURPOSE - TO PROCESS THE FIELD ARRAY AND SET UP THE ROW AND 

 437 C COLUMN IDENTIFIERS. 

 438 C VARIABLES - 

 439 C ICOL(K,L) = L-TH SET OF FLAG NUMBERS FOR A GRID COLUMN 

 440 C K=1 : COLUMN NUMBER, N 

 441 C K=2 : FIRST COMPUTATIONAL ROW, MA 

 442 C K=3 : LAST COMPUTATIONAL ROW, MB 

 443 C K=4 : LOWER END BOUNDARY CONDITION: 

 444 C 0=WATER LEVEL 

 445 C 1=FLOWRATE 

 446 C 2=ZERO FLOW 

 447 C K=5 : UPPER END BOUNDARY CONDITION (SEE K=4) 

 448 C IFIELD(N,M) = FIELD SPECIFICATION ARRAY = IJ =10*I+J, WHERE 

 449 C I=0 : LAND GRID 

 450 C 1 : HALF LAND, HALF WATER GRID 

 451 C 2,5,6 : WATER GRID(S) 

 452 C JFIELD(N,M) = FIELD SPECIFICATION ARRAY = IJ =10*I+J, WHERE 

 453 C I=0 : LAND GRID 

 454 C 1 : HALF LAND, HALF WATER GRID 

 455 C 2 : NON-BOUNDARY WATER GRID 

 456 C 3 : BOUNDARY GRID FOR WATER LEVEL 

 457 C 4 : BOUNDARY GRID FOR FLOWRATE 

 458 C 5 : BOUNDARY GRID FOR WATER FALLS 

 459 C KOCNBC : OCEANIC BOUNDARY CONDITION GRID (=5) 

 460 C KRIVBC : RIVERINE BOUNDARY CONDITION GRID=KOCNBC+1 

 461 C J=0 : X-, Y-FLOW 

 462 C 1 : NO X-FLOW 

 463 C 2 : NO Y-FLOW 

 464 C 3 : NO X-, Y-FLOW 

 465 INCLUDE 'COMM20.FOR' 

 466 DIMENSION NUM(NSIZE),JFIELD(NSIZE,MSIZE) 

 467 KRIVBC=KOCNBC+1 

 468 KFALLS=KOCNBC-1 

 469 DO 100 N=1,NMAX 

 470 NUM(N)=N 

 471 DO 100 M=1,MMAX 

 472 100 JFIELD(N,M)=IFIELD(N,M) 

 473 C RESET JFIELD AT BOUNDARIES: 3=WATER LEVEL 4=FLOWRATE 5=WATER FA

 474 IF(NUMOBC.LE.0)GOTO 120 

 475 DO 110 I=1,NUMOBC 

 476 DO 110 M=MB1(I),MB2(I) 
31

 477 DO 110 N=NB1(I),NB2(I) 

 478 JFIELD(N,M)=30+MOD(JFIELD(N,M),10) 

 479 IF(JTPO(I).EQ.2)JFIELD(N,M)=40+MOD(JFIELD(N,M),10) 

 480 110 CONTINUE 

 481 C RIVERS 

 482 120 IF(NUMRIV.LE.0)GOTO 140 

 483 DO 130 I=1,NUMRIV 

 484 DO 130 M=MR1(I),MR2(I) 

 485 DO 130 N=NR1(I),NR2(I) 

 486 IF(JTPR(I).EQ.1)JFIELD(N,M)=40+MOD(JFIELD(N,M),10) 

 487 IF(JTPR(I).EQ.2)JFIELD(N,M)=20+MOD(JFIELD(N,M),10) 

 488 130 CONTINUE 

 489 

 490 C FIND THE ICOL PARAMETERS 

 491 140 DO 150 J=1,NM2SIZ 

 492 DO 150 I=1,5 

 493 ICOL(I,J)=0 

 494 150 IROW(I,J)=0 

 495 ICOUNT=0 

 496 NCOL=0 

 497 DO 190 N=1,NMAX 

 498 ISTART=0 

 499 DO 190 M=1,MMAX 

 500 IC=JFIELD(N,M)/10 

 501 IF(IC.EQ.0.OR.IC.GE.3)GOTO 190 

 502 C INSERT GRID LINE SPECS IF THIS GRID STARTS A LINE 

 503 IF(ISTART.EQ.1)GOTO 170 

 504 ISTART=1 

 505 NCOL=NCOL+1 

 506 C DO A FIX-UP IF NCOL IS TOO LARGE FOR ARRAY 

 507 IF(NCOL.LE.NM2SIZ)GOTO 160 

 508 NCOL=NM2SIZ 

 509 ICOUNT=ICOUNT+1 

 510 160 ICOL(1,NCOL)=N 

 511 ICOL(2,NCOL)=M 

 512 C DETERMINE LOWER END BOUNDARY CONDITION 

 513 ICOL(4,NCOL)=2 

 514 IF(M.EQ.1)GOTO 170 

 515 I=JFIELD(N,M-1)/10 

 516 J=JFIELD(N,M-1)-10*I 

 517 IF(J.EQ.1.OR.J.EQ.3)GOTO 170 

 518 IF(I.EQ.3)ICOL(4,NCOL)=0 

 519 IF(I.EQ.4)ICOL(4,NCOL)=1 

 520 IF(I.EQ.5)ICOL(4,NCOL)=2 

 521 C CHECK FOR UPPER END BOUNDARY CONDITIONS 

 522 170 ICOL(3,NCOL)=M 

 523 ICOL(5,NCOL)=2 

 524 IF(M.EQ.MMAX)GOTO 180 

 525 J=JFIELD(N,M)-10*(JFIELD(N,M)/10) 

 526 IF(J.EQ.1.OR.J.EQ.3)GOTO 180 

 527 IP=JFIELD(N,M+1)/10 

 528 IF(IP.GT.0.AND.IP.LT.3)GOTO 190 

 529 IF(IP.EQ.3)ICOL(5,NCOL)=0 

 530 IF(IP.EQ.4)ICOL(5,NCOL)=1 

 531 IF(IP.EQ.5)ICOL(5,NCOL)=2 

 532 180 ISTART=0 

 533 190 CONTINUE 

 534 C FIND THE IROW PARAMETERS 

 535 200 JCOUNT=0 

 536 NROW=0 

 537 DO 240 M=1,MMAX 

 538 ISTART=0 

 539 DO 240 N=1,NMAX 

 540 IC=JFIELD(N,M)/10 

 541 IF(IC.EQ.0.OR.IC.GE.3)GOTO 240 

 542 C BEGIN TO INSERT LINE SPECS 

 543 IF(ISTART.GT.0)GOTO 220 

 544 ISTART=1 

 545 NROW=NROW+1 

 546 C DO A FIX-UP IF NECESSARY 

 547 IF(NROW.LE.NM2SIZ)GOTO 210 

 548 NROW=NM2SIZ 

 549 JCOUNT=JCOUNT+1 

 550 210 IROW(1,NROW)=M 

 551 IROW(2,NROW)=N 

 552 C DETERMINE LOWER END BOUNDARY CONDITION 

 553 IROW(4,NROW)=2 

 554 IF(N.EQ.1)GOTO 220 

 555 I=JFIELD(N-1,M)/10 

 556 J=JFIELD(N-1,M)-10*I 

 557 IF(J.EQ.2.OR.J.EQ.3)GOTO 220 

 558 IF(I.EQ.3)IROW(4,NROW)=0 

 559 IF(I.GE.4)IROW(4,NROW)=1 

 560 IF(I.GE.5)IROW(4,NROW)=2 

 561 C CHECK FOR UPPER END BOUNDARY 

 562 220 IROW(3,NROW)=N 

 563 IROW(5,NROW)=2 

 564 IF(N.EQ.NMAX)GOTO 230 

 565 J=JFIELD(N,M)-10*(JFIELD(N,M)/10) 

 566 IF(J.EQ.2.OR.J.EQ.3)GOTO 230 

 567 IP=JFIELD(N+1,M)/10 

 568 IF(IP.GT.0.AND.IP.LT.3)GOTO 240 

 569 IF(IP.GE.3)IROW(5,NROW)=0 

 570 IF(IP.GE.4)IROW(5,NROW)=1 

 571 IF(IP.GE.5)IROW(5,NROW)=2 

 572 230 ISTART=0 

 573 240 CONTINUE 

 574 C CHECK THE COUNTS 

 575 280 IF(ICOUNT.GT.0)WRITE(IO,290)NM2SIZ,ICOUNT 

 576 290 FORMAT(5X,'*** ERROR IN FLAGS: NUMBER OF ROW STRINGS EXCEEDS ',I4, 

 577 1 ' BY ',I4) 

 578 IF(JCOUNT.GT.0)WRITE(IO,295)NM2SIZ,JCOUNT 

 579 295 FORMAT(5X,'*** ERROR IN FLAGS: NUMBER OF COLUMN STRINGS EXCEEDS', 

 580 1 I4,' BY ',I4) 

 581 C GET FIRST, LAST COLUMN IN EACH ROW. 

 582 DO 310 M=1,MMAX 

 583 NA=NMAX+1 

 584 NB=1 

 585 DO 300 N=1,NMAX 

 586 IF(IFIELD(N,M)/10.EQ.0)GOTO 300 

 587 NA=MIN0(N,NA) 

 588 NB=MAX0(N,NB) 

 589 300 CONTINUE 

 590 NAB(M)=1000*NA+NB 

 591 310 CONTINUE 

 592 C 

 593 C CREATE NEW IFIELD BY INSERTING RIGHT SIDE AND 

 594 C BOTTOM SIDE BARRIERS IN WATER CELLS 

 595 DO 320 M=1,MMAX 

 596 DO 320 N=1,NMAX 

 597 IF(IFIELD(N,M)/10.EQ.0)GOTO 320 

 598 c IF(IFIELD(N,M)/10.EQ.KOCNBC)GOTO 320 

 599 c IF(IFIELD(N,M)/10.EQ.KRIVBC)GOTO 320 

 600 IX=0 

 601 IF(M.EQ.MMAX.OR.IFIELD(N,MIN0(M+1,MMAX))/10.EQ.0)IX=1 

 602 IF(MOD(IFIELD(N,M),10).EQ.1.OR.MOD(IFIELD(N,M),10).EQ.3)IX=1 

 603 IY=0 

 604 IF(N.EQ.NMAX.OR.IFIELD(MIN0(N+1,NMAX),M)/10.EQ.0)IY=2 

 605 IF(MOD(IFIELD(N,M),10).EQ.2.OR.MOD(IFIELD(N,M),10).EQ.3)IY=2 

 606 IFIELD(N,M)=10*(IFIELD(N,M)/10)+IX+IY 

 607 320 CONTINUE 

 608 C OCEAN BOUNDARY CELLS 

 609 IF(NUMOBC.LE.0)GOTO 400 

 610 DO 390 I=1,NUMOBC 

 611 IX=0 

 612 IY=0 

 613 IF(IABS(ITPO(I)).EQ.1)THEN 

 614 IY=2 

 615 IF(ITPO(I).GT.0.AND.IFIELD(N,M+1).LT.9)IX=1 

 616 ENDIF 

 617 IF(IABS(ITPO(I)).EQ.2)THEN 

 618 IX=1 

 619 IF(ITPO(I).GT.0.AND.IFIELD(N+1,M).LT.9)IY=2 

 620 ENDIF 

 621 DO 390 M=MB1(I),MB2(I) 

 622 DO 390 N=NB1(I),NB2(I) 

 623 390 IFIELD(N,M)=10*KOCNBC+IX+IY 

 624 C RIVERS 

 625 400 IF(NUMRIV.LE.0)GOTO 430 

 626 DO 420 I=1,NUMRIV 

 627 IF(JTPR(I).NE.2)GOTO 420 

 628 IX=0 

 629 IY=0 

 630 IF(IABS(ITPR(I)).EQ.1)IY=2 

 631 IF(IABS(ITPR(I)).EQ.2)IX=1 

 632 DO 410 M=MR1(I),MR2(I) 

 633 DO 410 N=NR1(I),NR2(I) 

 634 410 IFIELD(N,M)=10*KRIVBC+IX+IY 

 635 420 CONTINUE 

 636 430 CONTINUE 

 637 C MFLUX(,) = INDEX FOR MASS FLUX IN X-DIRECTION (0=NO, 1=YES) 

 638 C NFLUX(,) = INDEX FOR MASS FLUX IN Y-DIRECTION (0=NO, 1=YES) 

 639 C LOOP DOWN THE LINES 

 640 DO 450 M=1,MMAX 

 641 MP=MIN0(MMAX,M+1) 

 642 DO 450 N=1,NMAX 

 643 NP=MIN0(NMAX,N+1) 

 644 I=MOD(IFIELD(N,M),10) 

 645 IX=1 

 646 IF(IFIELD(N,M).LT.10.OR.IFIELD(N,MP).LT.10)IX=0 

 647 IF(I.EQ.1.OR.I.EQ.3.OR.M.EQ.MMAX)IX=0 

 648 MFLUX(N,M)=IX 

 649 IY=1 

 650 IF(IFIELD(N,M).LT.10.OR.IFIELD(NP,M).LT.10)IY=0 

 651 IF(I.EQ.2.OR.I.EQ.3.OR.N.EQ.NMAX)IY=0 

 652 NFLUX(N,M)=IY 

 653 450 CONTINUE 

 654 RETURN 

 655 END 

 656 C 

 657 C--------------------------------------------------------------- 

 658 C 

 659 SUBROUTINE SETUP 

 660 

 661 C MAY 1984 (REVISED APRIL 88) K. W. HESS 

 662 C PURPOSE - TO INITIALIZE THE PARAMETERS AFTER ALL INPUT 

 663 C FILES HAVE BEEN READ IN. 

 664 C VARIABLES - 

 665 C DPADX = GRADIENT OF ATMOS. PRESSURE IN X-DIRECTION 

 666 C (UNITS = MB/KM = (100 N/M**2)/(1000 M) 

 667 C SO DPADX*(.1/RHOW) HAS MKS UNITS 

 668 C ICS = INDEX FOR READ IN OF INITIAL CONDITIONS 

 669 C (0=NO, 1=YES) 

 670 

 671 INCLUDE 'COMM20.FOR' 

 672 C CHECK BOTTOM DRAG 

 673 IF(INTER.EQ.0)IBOTV=1 

 674 C SET CORIOLIS PARAMETERS 

 675 COR=0.0 

 676 IF(ICOR.NE.0)COR=2.*OMEGA*SIN(RAD*BSNLAT) 

 677 FCOR0=DTE*COR 

 678 DFDM=0.0 

 679 DFDN=0.0 

 680 IF(IABS(ICOR).GE.2)THEN 

 681 CC=-DTE*2.*OMEGA*COS(BSNLAT*RAD)*DL*RAD/60./1852. 

 682 DFDM=CC*COS(BSNANG*RAD) 

 683 DFDN=CC*SIN(BSNANG*RAD) 

 684 END IF 

 685 C SET DENSITY COUPLING 

 686 ICOUPL=MIN0(MAX0(0,ICOUPL),2) 

 687 C COMPUTE VERTICAL GRID PARAMETERS 

 688 DQ=1./FLOAT(LAYRS) 

 689 HALFDQ=.5*DQ 

 690 TWODQ=2.*DQ 

 691 LBOT=LAYRS+1 

 692 C GET IFIELD 

 693 CALL FLAGS ! newest version 

 694 C INITIALIZE VISCOSITIES AND GET MAX, MIN CELL DEPTHS 

 695 DMAX=0.0 

 696 DMIN=1.E+10 

 697 DO 130 M=1,MMAX 

 698 DO 130 N=1,NMAX 

 699 IF(IFIELD(N,M).LT.10)GOTO 130 

 700 DMAX=AMAX1(DMAX,D(N,M)) 

 701 DMIN=AMIN1(DMIN,D(N,M)) 

 702 IF(ICS.EQ.1)GOTO 130 

 703 AH(N,M)=D(N,M)*AH00 

 704 AHC(N,M)=D(N,M)*AH00 

 705 DO 120 L=1,LBOT 

 706 AH3(L,N,M)=AH(N,M) 

 707 S(L,N,M)=SAL0 

 708 T(L,N,M)=TMP0 

 709 IF(L.LT.LBOT)DV(L,N,M)=DV00 

 710 120 IF(L.LT.LBOT)AV(L,N,M)=AV00 

 711 130 CONTINUE 

 712 

 713 C GET VERTICAL INTEGRATION COEFFICIENT FOR LEVELS (NOT LAYERS) 

 714 148 DO 160 L=1,LBOT 

 715 CI(L)=1.0/FLOAT(LBOT-1) 

 716 IF(L.EQ.1.OR.L.EQ.LBOT)CI(L)=0.5/FLOAT(LBOT-1) 

 717 160 CONTINUE 

 718 C EDGE FUNCTION 

 719 DO 250 M=1,MMAX 

 720 DO 250 N=1,NMAX 

 721 FEDGE(N,M)=1.0 

 722 II=IFIELD(N,M)/10 

 723 IF(II.EQ.KOCNBC)FEDGE(N,M)=0.0 

 724 IF(M.EQ.1.OR.M.EQ.MMAX)GOTO 250 

 725 IF(N.EQ.1.OR.N.EQ.NMAX)GOTO 250 

 726 IF(II.EQ.KOCNBC)GOTO 250 

 727 IF(IFIELD(N,M+1)/10.EQ.KOCNBC.OR.IFIELD(N,M-1)/10.EQ.KOCNBC. 

 728 1 OR.IFIELD(N+1,M)/10.EQ.KOCNBC.OR.IFIELD(N-1,M)/10.EQ.KOCNBC) 
32

 729 2 FEDGE(N,M)=0.5 

 730 250 CONTINUE 

 731 RETURN 

 732 END 

 733 C======================================================================= 

 734 C MECCA FILE : MPRINT 

 735 C----------------------------------------------------------------------- 

 736 C 

 737 SUBROUTINE OUTPUT 

 738 C APRIL 1988 HESS MEAD VAX 

 739 C PURPOSE - TO PRINT OUT VARIABLES AT START, OTHER SELECTED TIMES 

 740 C AND END 

 741 INCLUDE 'COMM20.FOR' 

 742 C 

 743 C INITIAL PRINTOUTS 

 744 IF(NSTI.EQ.0)CALL PRNCON(1) 

 745 IF(NSTI.EQ.0)CALL PRNBCG(1) 

 746 C SAVE INTERMEDIATE RESULTS EACH HRSAVE HOURS 

 747 IF(NSTI.GT.0.AND.MOD(NSTI,IHR*IFIX(HRSAVE)).EQ.0)CALL MEDSAV 

 748 C STORE VALUES FOR GRAPHING 

 749 CALL PGRAPH 

 750 C PRINT OUT SELECTED FIELDS 

 751 CALL PRINTA 

 752 C END OF RUN 

 753 IF(ISTOP.EQ.1)GOTO 120 

 754 IF(NSTI.LT.NSTIMX)GOTO 700 

 755 C WRITE HOURS TO CONSOLE 

 756 120 NRR=NN+IFIX(HR0) 

 757 CALL PRNCON(0) 

 758 WRITE(IO,525) 

 759 525 FORMAT(/,1X,'VII. RUN COMPLETION',55('-'),/) 

 760 WRITE(IO,520)NEGS 

 761 520 FORMAT(5X,'NO. OF TIMES A WATER TOTAL DEPTH WENT NEGATIVE=',I4) 

 762 WRITE(IO,530)FPRINT,FMED 

 763 WRITE(ISCR,530)FPRINT,FMED 

 764 530 FORMAT(5X,'PRINT OUTPUT IS IN FILE : ',A40,/ 

 765 1 5X,'VELOCITY DATA IS IN FILE: ',A40) 

 766 IF(IGPH.GT.1)WRITE(ISCR,540)FGRAPH 

 767 IF(IGPH.GT.1)WRITE(IO ,540)FGRAPH 

 768 540 FORMAT(5X,'GRAPHING OUTPUT IS IN : ',A40) 

 769 620 WRITE(ISCR,630) 

 770 630 FORMAT(1X,'RUN COMPLETE') 

 771 IF(IO.NE.ISCR)WRITE(IO,640) 

 772 640 FORMAT(1X,'RUN COMPLETE',//,1X,74('-')) 

 773 WRITE(IO, *)'ISTOP=',ISTOP 

 774 WRITE(ISCR,*)'ISTOP=',ISTOP 

 775 700 CONTINUE 

 776 RETURN 

 777 END 

 778 C 

 779 C-------------------------------------------------------------------- 

 780 C 

 781 SUBROUTINE MEDSAV 

 782 C PURPOSE - TO SAVE RESULTS TO AN INTERMEDIATE FILE 

 783 C 

 784 INCLUDE 'COMM20.FOR' 

 785 C NOTIFY PRINT FILE 

 786 WRITE(IO,110)NSTI,UT 

 787 110 FORMAT(/,1X,'MEDSAV: NSTI=',I5,' UT=',f10.4) 

 788 C OPEN FILES 

 789 CALL FUOPEN(LUMED,FMED) 

 790 C WRITE TO DATA FILE 

 791 K=10+KONCEN 

 792 WRITE(LUMED)NMAX,MMAX,LBOT,NSTET,UT,YEAR,K 

 793 WRITE(LUMED)SE,UE,VE,SOLD,UHOLD,VHOLD,AH,AV,PHI,TBX,TBY, 

 794 1 U,V,W,THETA1,THETA2,THETA3 

 795 WRITE(LUMED)AH3,WX,WY,TSX,TSY 

 796 IF(KONCEN.GT.0)WRITE(LUMED)S,T,DV,RI,NSTINF 

 797 C CLOSE FILES 

 798 CLOSE (LUMED) 

 799 120 RETURN 

 800 END 

 801 C 

 802 C----------------------------------------------------------------------- 

 803 C 

 804 SUBROUTINE PRINTA 

 805 C 1986 MEAD K.HESS VAX 

 806 C PURPOSE - TO CALL THE VARIOUS OCCASIONAL PRINTING SUBROUTINES 

 807 C VARIABLES - 

 808 C HROUT0 = HOUR OF FIRST P/O 

 809 INCLUDE 'COMM20.FOR' 

 810 NOUT0=AMAX1(1.,HROUT0*3600.01/DTI) 

 811 NOUT1=AMAX1(1.,HROUT *3600.01/DTI) 

 812 IF(HR1.LT.HROUT0)GOTO 120 

 813 c IF(.NOT.(NSTI.EQ.NSTIMX.OR.MOD(NSTIT-NOUT0,NOUT1).EQ.0.OR. 

 814 IF(.NOT.(NSTI.EQ.NSTIMX.OR.MOD(NSTIT,NOUT1).EQ.0.OR. 

 815 1 NSTI.EQ.0.OR.ISTOP.EQ.1))GOTO 110 

 816 write(6,*)'PRINTA: NOUT0,NOUT1=',nout0,nout1 

 817 IF(NSTI.EQ.0)WRITE(IO,100) 

 818 100 FORMAT(//,1X,'IV. INITIAL FIELDS',55('-')) 

 819 C PRINT (B) TOP VIEW OF EXTERNAL MODE 

 820 CALL PRINTX 

 821 C PRINT (C) ALONG A SLICE 

 822 CALL PSLICE 

 823 C PRINT (D) AT ALL LEVELS AT ONE CELL 

 824 CALL PRINTI 

 825 110 CONTINUE 

 826 120 CONTINUE 

 827 IF(NSTI.EQ.0)WRITE(IO,130) 

 828 130 FORMAT(/,1X,'V. RUN-TIME OUTPUT',55('-')) 

 829 RETURN 

 830 END 

 831 C 

 832 C------------------------------------------------------------------ 

 833 C 

 834 SUBROUTINE PRINTI 

 835 C MAY 1984 K. W. HESS 

 836 C PURPOSE - TO PRINT OUT THE INTERNAL-MODE VARIABLES. 

 837 INCLUDE 'COMM20.FOR' 

 838 DIMENSION RJ(7),FPX(LSIZE),FPY(LSIZE),WT(LSIZE),TRAD(LSIZE) 

 839 C CHECK FOR PRINT 

 840 IF(NPRMN.LE.0)GOTO 450 

 841 WRITE(IO,100)UT 

 842 100 FORMAT(/,1X,'D. INTERNAL MODE VARIABLES AT ALL LEVELS IN A CELL', 

 843 1 ' AT UT=',F9.4) 

 844 WFACT=10.**NINT(ALOG10(DL/DMAX/DQ)) 

 845 C GET ROW OR COLUMN INDICES 

 846 DO 440 I=1,NPRMN 

 847 M=IPRMN(I)/1000 

 848 N=IPRMN(I)-1000*M 

 849 MP=MIN0(M+1,MMAX) 

 850 NP=MIN0(N+1,NMAX) 

 851 C CHECK FOR CELL INSIDE WATER FIELD 

 852 IF(N.GE.1.AND.M.GE.1.AND.N.LE.NMAX.AND.M.LE.MMAX)GOTO 120 

 853 WRITE(IO,110)N,M 

 854 110 FORMAT(3X,'ERROR: CELL N=',I2,', M=',I2,' IS OUTSIDE GRIDMESH') 

 855 GOTO 440 

 856 120 IF(IFIELD(N,M).GE.10)GOTO 140 

 857 WRITE(IO,130)N,M 

 858 130 FORMAT(3X,'ERROR: CELL N=',I3,', M=',I3,' IS NOT WATER') 

 859 GOTO 440 

 860 140 CONTINUE 

 861 WRITE(IO,150)N,M,UT,NSTI,WFACT 

 862 150 FORMAT(/,X,'N=',I3,' M=',I3,' UT=',F10.4,' NSTI=',I6, 

 863 1 7x,'f=',E10.4,/,1X, 

 864 1 ' L',6x,'UTm',7X,'UTp',7x,'VTm',7X,'VTp',7X,'Wxf',7X, 

 865 2 ' S ',7x,' T ') 

 866 IF(M.LE.0.OR.N.LE.0)GOTO 440 

 867 C VELOCITIES 

 868 DHDT1=(SE(N,M)-SOLD(N,M))/DTI 

 869 DO 160 L=1,LBOT 

 870 RJ(1)=UE(N,M-1)+U(L,N,M-1) 

 871 RJ(2)=UE(N,M)+U(L,N,M) 

 872 RJ(3)=VE(N-1,M)+V(L,N-1,M) 

 873 RJ(4)=VE(N,M)+V(L,N,M) 

 874 Q=FLOAT(1-L)*DQ 

 875 WT(L)=W(L,N,M)+(1.+Q)*DHDT1 

 876 RJ(5)=W(L,N,M)*WFACT 

 877 RJ(6)=S(L,N,M) 

 878 RJ(7)=T(L,N,M) 

 879 WRITE(IO,155)L,(RJ(K),K=1,7) 

 880 155 FORMAT(2X,I2,7F10.3,F10.4) 

 881 160 CONTINUE 

 882 C INTERNAL HEATING 

 883 FS=0.0 

 884 FQ=0.0 

 885 IF(NSTI.GT.ISPLIT.AND.IHEAT.GT.0.AND.KONCEN.GE.2) 

 886 1 CALL HEATZ(N,M,TRAD,FTSURF) 

 887 WRITE(IO,170) 

 888 170 FORMAT(1X,' L',4x,'10+4 Av ',2X,'10+4 Dv ',5X,'Ri',7X, 

 889 1 'Trad',6X,'AH3',6x,'Rho',5x,'10+6 Tau') 

 890 C DIFFUSIVITY, DENSITY, STRESS 

 891 DZ=2.*DQ*(D(N,M)+SE(N,M)) 

 892 DO 195 L=1,LAYRS 

 893 RJ(1)=AV(L,N,M)*10000. 

 894 RJ(2)=DV(L,N,M)*10000. 

 895 RJ(3)=RI(L,N,M) 

 896 TRAD(L)=0. 

 897 TW=T(1,N,M) 

 898 RJ(4)=TRAD(L) 

 899 RJ(5)=AH3(L,N,M)/(D(N,M)+SE(N,M)) 

 900 RJ(6)=RHOW+1000.*FRHO(S(L,N,M),T(L,N,M)) 

 901 RJ(7)=1.E+6*AV(L,N,M)*(U(L,N,M)-U(L+1,N,M)+U(L,N,M-1) 

 902 1 -U(L+1,N,M-1)+V(L,N,M)-V(L+1,N,M)+V(L,N-1,M)-V(L+1,N-1,M))/DZ 

 903 WRITE(IO,180)L,(RJ(K),K=1,7) 

 904 c180 FORMAT(2X,I2,5F10.3,3x,F10.4) 

 905 180 FORMAT(2X,I2,7F10.3) 

 906 195 CONTINUE 

 907 

 908 C TWO-DIMENSIONAL VARIABLES 

 909 MP=MIN0(M+1,MMAX) 

 910 NP=MIN0(N+1,NMAX) 

 911 H1=0.5*(D(N,M)+SE(N,M)+D(N,MP)+SE(N,MP)+E) 

 912 H2=0.5*(D(N,M)+SE(N,M)+D(NP,M)+SE(NP,M)+E) 

 913 C PRINT OTHER VARIABLES, LIKE DEPTH AND BOTTOM STRESSES 

 914 FAH=AH(N,M)/(D(N,M)+SE(N,M)) 

 915 UO=UHOLD(N,M)/H1 

 916 VO=VHOLD(N,M)/H2 

 917 UBOT=U(LBOT,N,M) 

 918 VBOT=V(LBOT,N,M) 

 919 LMID=MAX0(1,LBOT/2) 

 920 PHIX=.5*(PHI(N,M)+PHI(N,M+1)) 

 921 PHIY=.5*(PHI(N,M)+PHI(N+1,M)) 

 922 WRITE(IO,250)SE(N,M),UE(N,M),VE(N,M),D(N,M),TBX(N,M),TBY(N,M), 

 923 1 QI,QA,QB,QS,QE, 

 924 2 GSTARX(N,M),GSTARY(N,M),AREA(N,M),BX(N,M),BY(N,M), 

 925 3 PHI(N,M),UO,VO,SOLD(N,M),FAH, 

 926 4 THETA1(N,M),THETA2(N,M),THETA3(N,M), 

 927 5 THETSU(N,M),THETSV(N,M),FEDGE(N,M), 

 928 6 UBOT,VBOT,LMID,W(LMID,N,M),TSX(N,M),TSY(N,M), 

 929 7 DPADX,DPADY,SE(N,MP),SE(NP,M),AHC(N,M),PHIX,PHIY 

 930 250 FORMAT(3X,' SE=',F8.5,' UE,VE=',2F8.5, 

 931 1 ' D=',F7.2,' TBX,Y=',2E11.4,/,3X,' QI=',E9.3, 

 932 2 ' QA=',E9.3,' QB=',E9.3,' QS=',E9.3,' QE=',E9.3, 

 933 3 /,3X,' GSTARX,Y=',2E11.4,' AREA=',F5.3, 

 934 4 ' BX=',F5.3,' BY=',F5.3,/,3X,' PHI=',F7.5, 

 935 5 ' UHOLD/D=',F7.3,' VHOLD/D=',F7.3,' SOLD=',F6.3,' AH/D=',F9.3, 

 936 6 /,3X,' THETA1,2,3=',3F7.3,' THETSU,V=',2E10.3,' EDG=',F3.1,/, 

 937 7 3X,' U,VBOT=',2E11.4,' W(',I2,')=',E10.4,' TSX,Y=',2E9.2, 

 938 8 /,3X,' DPADX,Y=',2E9.2,' SEmp,SEnp=',F7.4,F8.4,' AHC=',F9.3, 

 939 9 /,3x,' PHIX,Y=',2F10.7) 

 940 440 CONTINUE 

 941 450 RETURN 

 942 END 

 943 C 

 944 C---------------------------------------------------------------------- 

 945 C 

 946 SUBROUTINE PRINTX 

 947 C MAY 1984 K. W. HESS MEAD VAX11/750 

 948 C PURPOSE - TO PRINT OUT THE TOP VIEWS OF EXTERNAL VARIABLES 

 949 C VARIABLES - 

 950 C I = VARIABLE INDEX 

 951 C 1 = WATER LEVEL 

 952 C 2 = U MEAN VELOCITY 

 953 C 3 = V MEAN VELOCITY 

 954 C 4 = TOTAL SURFACE X VELOCITY 

 955 C 5 = TOTAL SURFACE Y VELOCITY 

 956 C 6 = SURFACE SALINITY 

 957 C 7 = BOTTOM SALINITY 

 958 C 8 = SURFACE TEMPERATURES (C) 

 959 C 9 = BOTTOM TEMPERATURES (C) 

 960 C 10 = HORIZONTAL VISCOSITY 

 961 C 11 = VERTICAL VISCOSITY 

 962 C 12 = WX 

 963 C 13 = WY 

 964 C JPRNT() = PRINT INDEX: IF=1 , PRINT 

 965 INCLUDE 'COMM20.FOR' 

 966 DIMENSION NUM(NSIZE),NO(NSIZE),JFIELD(NSIZE) 

 967 CHARACTER*1 ANUM(3*NSIZE) 

 968 CHARACTER*43 QTITLE(13) 

 969 DATA QTITLE/ 

 970 1 'WATER LEVELS (CM) ', 

 971 2 'X-DIR VERTICALLY-AVERAGED VELOCITIES (CM/S)', 

 972 2 'Y-DIR VERTICALLY-AVERAGED VELOCITIES (CM/S)', 

 973 3 'X-DIR TOTAL SURFACE VELOCITIES (CM/S) ', 

 974 3 'Y-DIR TOTAL SURFACE VELOCITIES (CM/S) ', 

 975 3 'SURFACE SALINITIES (PPT) ', 

 976 4 'BOTTOM SALINITIES (PPT) ', 

 977 5 'SURFACE TEMPERATURES (DEG. C) ', 

 978 5 'BOTTOM TEMPERATURES (DEG. C) ', 

 979 5 'HORIZONTAL VISCOSITY (M**2/S) ', 

 980 5 'VERTICAL VISCOSITY x 100 (M**2/S ) ', 
33

 981 5 'WX (M/S) ', 

 982 5 'WY (M/S) '/ 

 983 DIMENSION LEV(13),ISEL(13),FAC(13) 

 984 DATA LEV/1,1,1,1,1,1,1,1,1,1,1,1,1/ 

 985 DATA FAC/100.,100.,100.,100.,100.,1.,1.,1.,1.,1.,100.,1.,1./ 

 986 DATA ISEL/1,2,3,4,5,9,9,10,10,11,15,18,19/ 

 987 LEV(7)=LBOT-1 

 988 LEV(9)=LBOT-1 

 989 LEV(11)=LBOT/2 

 990 N3MAX=3*NMAX 

 991 DO 100 N=1,NMAX 

 992 100 NO(N)=N 

 993 C LOOP THRU THE VARIABLES 

 994 ICALL=0 

 995 DO 250 I=1,13 

 996 IF(JPRNT(I).NE.1)GOTO 250 

 997 C PRINT PAGE FORM 

 998 IF(KPRNT2.NE.2)WRITE(IO,110) 

 999 110 FORMAT(1X) 

 1000 IF(KPRNT2.EQ.2)WRITE(IO,120) 

 1001 120 FORMAT(1H1) 

 1002 C WRITE DESCRIPTOR LINE 

 1003 ICALL=ICALL+1 

 1004 IF(ICALL.EQ.1)WRITE(IO,125) 

 1005 125 FORMAT(/,1X,'B. TOP VIEW OF SELECTED VARIABLE FIELDS') 

 1006 c WRITE(IO,130)QTITLE(I),UT,NSTI,HR,HR1,CUMDAY 

 1007 c130 FORMAT(2X,A43,/,1X,'UT=',F10.4,' NSTI=',I5,' HR=',F8.2,' CUM.HR=' 

 1008 RELDAY=HR/24. 

 1009 WRITE(IO,130)QTITLE(I),YEAR,UT,RELDAY,CUMDAY,NSTI 

 1010 130 FORMAT(2X,A43,/,1X,'YR=',F5.0,' UT=',F10.4, 

 1011 1 ' REL.DAY=',F8.2,' CUM.DAY=',F8.2,' NSTI=',I5) 

 1012 NPL=25 ! number per line 

 1013 KMAX=1+(NMAX-1)/NPL 

 1014 DO 220 K=1,KMAX 

 1015 N1=1+NPL*(K-1) 

 1016 N2=MIN0(NMAX,N1+NPL-1) 

 1017 WRITE(IO,134)(NO(N),N=N1,N2) 

 1018 134 FORMAT(4X,40I3,3(/5X,40I3)) 

 1019 C LOOP THRU ARRAY AND GET VALUE 

 1020 DO 180 M=1,MMAX 

 1021 DO 136 N=1,NMAX 

 1022 136 NUM(N)=0 

 1023 DO 140 N=N1,N2 

 1024 JFIELD(N)=IFIELD(N,M) 

 1025 140 NUM(N)=NINT(FAC(I)*SELECT(ISEL(I),LEV(I),N,M)) 

 1026 C OPTION 1: PRINT OUT VECTOR AS STRAIGHT NUMBERS 

 1027 IF(KPRNT1.EQ.2)GOTO 160 

 1028 WRITE(IO,150)M,(NUM(N),N=N1,N2) 

 1029 150 FORMAT(1X,I3,40I5,3(/4X,40I5)) 

 1030 GOTO 180 

 1031 C OPTION 2: PRINT OUT VECTORS AS CHARACTERS, WITH "." FOR LAND 

 1032 160 CALL PRNCHR(3,NUM,JFIELD,ANUM,NMAX) 

 1033 N1A=1+3*(N1-1) 

 1034 N2A=MIN0(3*NMAX,N1A-1+3*NPL) 

 1035 WRITE(IO,170)M,(ANUM(N),N=N1A,N2A) 

 1036 170 FORMAT(1X,I3,140A1,3(/5X,140A1)) 

 1037 180 CONTINUE 

 1038 220 CONTINUE 

 1039 250 CONTINUE 

 1040 RETURN 

 1041 END 

 1042 C 

 1043 C------------------------------------------------------------------- 

 1044 C 

 1045 SUBROUTINE PRNCHR(MAXDIG,NUM,JFIELD,ANUM,KMAX) 

 1046 C OCTOBER 1984 K. W. HESS MEAD VAX11/750 

 1047 C PURPOSE - TO CONVERT NUMERIC VALUES TO CHARACTER VALUES. 

 1048 C IT'S ASSUMED THAT THE OUTPUT NUMBER IS AT MOST 

 1049 C 3 (=MAXDIG) DIGITS LONG. 

 1050 INCLUDE 'COMM20.FOR' 

 1051 DIMENSION NUM(NPMSIZ),IMAX(4),JFIELD(NPMSIZ) 

 1052 CHARACTER*1 ANUM(3*NPMSIZ) 

 1053 CHARACTER*1 DIGIT(10),CHAR(5) 

 1054 DATA DIGIT/'0','1','2','3','4','5','6','7','8','9'/ 

 1055 DATA CHAR/' ','0','-','*','.'/ 

 1056 DATA IMAX/9,99,999,9999/ 

 1057 C LOOP THRU THE NUMBERS 

 1058 DO 200 N=1,KMAX 

 1059 NO=NUM(N) 

 1060 IS=1 

 1061 IF(NO.LT.0)IS=-1 

 1062 NO=NO*IS 

 1063 IF(JFIELD(N).GT.9)GOTO 110 

 1064 C LAND GRID SQUARES 

 1065 DO 100 I=1,MAXDIG 

 1066 II=I+MAXDIG*(N-1) 

 1067 ANUM(II)=CHAR(1) 

 1068 IF(I.EQ.MAXDIG)ANUM(II)=CHAR(5) 

 1069 100 CONTINUE 

 1070 GOTO 200 

 1071 C NUMBERS TOO LARGE: PRINT **** 

 1072 110 IF(NO.LE.IMAX(MAXDIG).AND.IS*NO.GT. 

 1073 1 -IMAX(MAXDIG)/10)GOTO 130 

 1074 DO 120 I=1,MAXDIG 

 1075 II=I+MAXDIG*(N-1) 

 1076 120 ANUM(II)=CHAR(4) 

 1077 GOTO 200 

 1078 C WATER GRID SQUARES: FIRST INSERT BLANKS 

 1079 130 DO 140 I=1,MAXDIG 

 1080 II=I+MAXDIG*(N-1) 

 1081 140 ANUM(II)=CHAR(1) 

 1082 C INSPECT GRIDS FROM LEFT TO RIGHT 

 1083 DO 150 J=1,MAXDIG 

 1084 I=MAXDIG+1-J 

 1085 II=I+MAXDIG*(N-1) 

 1086 IDIG=(NO-10**(MAXDIG+1-I)*(NO/(10**(MAXDIG+1-I)))) 

 1087 1 /10**(MAXDIG-I) 

 1088 ANUM(II)=DIGIT(IDIG+1) 

 1089 C LEADING BLANKS 

 1090 IF(NO.GT.10**J-1.OR.J.EQ.MAXDIG)GOTO 150 

 1091 ANUM(II-1)=CHAR(1) 

 1092 C SIGN CHARACTER 

 1093 IF(IS.LT.1)ANUM(II-1)=CHAR(3) 

 1094 GOTO 200 

 1095 150 CONTINUE 

 1096 200 CONTINUE 

 1097 RETURN 

 1098 END 

 1099 C 

 1100 C----------------------------------------------------------------------- 

 1101 C 

 1102 SUBROUTINE PRNCON(INDEX0) 

 1103 

 1104 C PURPOSE - TO PRINT MOST OF THE RUN PARAMETERS IN A COMPACT FOR 

 1105 C VARIABLES - 

 1106 C INDEX0 = PARAMETER TO SPECIFY PRINTOUT OF SECONDARY 

 1107 C VARIABLES LIKE DEPTHS (0=NO, 1=YES). USUALLY 

 1108 C INDEX0=1 AT START OF RUN, 0 LATER. 

 1109 INCLUDE 'COMM20.FOR' 

 1110 COMMON/A1/DTIMAX 

 1111 DIMENSION FRICH(10),FRR(10),FRT(10),NUM(101) 

 1112 DIMENSION JFIELD(40),ANUM(120) 

 1113 CHARACTER*2 TITLY(3) 

 1114 CHARACTER*2 CHNUM(2) 

 1115 CHARACTER*1 ANUM 

 1116 DATA CHNUM/'I.','VI'/,TITLY/'D.',' ',' '/ 

 1117 JN=1 

 1118 IF(INDEX0.EQ.0)JN=2 

 1119 WRITE(IO,70)VERS 

 1120 70 FORMAT(1X,'MECCA2 (MODEL FOR ESTUARINE AND COASTAL CIRCULATION', 

 1121 1 ' ASSESSMENT), VERSION ',F5.2) 

 1122 WRITE(IO,65)CHNUM(JN) 

 1123 65 FORMAT(1X,A2,' MODEL CONSTANTS',60(1H-)) 

 1124 C INPUT FILE NAMES 

 1125 IF(INDEX0.EQ.0)GOTO 85 

 1126 WRITE(IO,80)FGEO 

 1127 80 FORMAT(/,1X,'A. INPUT GEOGRAPHY FILE:',A40) 

 1128 85 CONTINUE 

 1129 C PRINT OUT INTERNAL (SET IN THE CODE) PARAMETERS 

 1130 WRITE(IO,90)AG,ALV,CPAIR,CWATER, 

 1131 1 E,EPSLON,IO,ISCR,OMEGA,PA,PI,RHOA,RHOW,SB,SOLAR,VONKAR 

 1132 90 FORMAT(/,1X,'B. INTERNAL PARAMETER VALUES:',/,' AG=',F6.3,' ALV=', 

 1133 1 E10.4,' CPAIR=',F6.1,' CWATER=',F6.1,' E=',E10.4,/, 

 1134 3 ' EPSLON=',F5.3,' IO=',I2,' ISCR=',I2,' OMEGA=',E9.3,' PA=', 

 1135 4 F8.1,' PI=',F9.7,' RHOA=',F5.3,/,' RHOW=',F6.1,' SB=',E9.3, 

 1136 5 ' SOLAR=',F6.1,' VONKAR=',F4.2) 

 1137 C INPUT DATA VALUES 

 1138 WRITE(IO,100) 

 1139 1 AH00,AH0,ALB,AV00,AV0,BSNANG,BSNLAT,BSNLON,CAH, 

 1140 2 CDRGWS,CDWB1,CDWB2,CDR1,CDR2,CLOUD,CR0,(CRICH(I),I=1,8), 

 1141 3 DL,DTE,DV0,DV00,D10PCT,DHAH,HR0,HRCONC,HRMAX,HROUT, 

 1142 4 HROUT0,IBETAA,IBETAH,IBETAP,IBOTV,ICOR,ICOUPL,ICPOS,IEXTRN,IGPH, 

 1143 6 IHEAT,IHVISC,INTER,ITOPV,IVISC,(JPRNT(I),I=1,13),KOCNBC, 

 1144 7 KONCEN,LAYRS,MCOR,MMAX,NCOR,NMAX,NUMOBC,NUMRIV,NUMBXY 

 1145 100 FORMAT(/,1X,'C. INPUT VALUES:',/,1X,'C.1 CONFIGURATION DATA',/, 

 1146 1 ' AH00=',F5.1,' AH0=',F5.1,' ALB=',F4.2, 

 1147 2 ' AV00=',F7.5,' AV0=',F7.5,' BSNANG=',F7.3,/,' BSNLAT=',F7.3, 

 1148 3 ' BSNLON',F8.3,' CAH=',F5.3,' CDRGWS=',F6.4,' CDWB1=',F6.4, 

 1149 4 ' CDWB2=',F6.4,/,' CDR1=',F8.6,' CDR2=',F8.6,' CLOUD=',F4.2, 

 1150 4 ' CN=',F4.2, 

 1151 5 ' CRICH1=',E10.4,/,' CRICH2=',E10.4,' CRICH3=',E10.4,' CRICH4=', 

 1152 6 E10.4,' CRICH5=',E10.4,/,' CRICH6=',E10.4,' CRICH7=',E10.4, 

 1153 7 ' CRICH8=',E10.4,' DL=',F8.1,' DTE=',F8.2,/,' DV00=',F8.6, 

 1154 7 ' DV0=',F8.6,' D10PCT=',F4.1,' DHAH=',F6.2, 

 1155 8 ' HR0=',F6.1,' HRCONC=',F6.1,/,' HRMAX=',F6.1,' HROUT=',F6.2, 

 1156 9 ' HROUT0=',F6.1,' IBETAA=',I1,' IBETAH=',I1,' IBETAP=',I1, 

 1157 1 ' IBOTV=',I1,/,' ICOR=',I1,' ICOUPL=',I1,' ICPOS=',I1, 

 1158 2 ' IEXTRN=',I1,' IGPH=',I2,' IHEAT=',I2,' IHVISC=',I2, 

 1159 3 ' INTER=',I2,' ITOPV=',I1,/,' IVISC=',I1, 

 1160 2 ' JPRNT=',13I2,' KOCNBC=',I2, 

 1161 3 ' KONCEN=',I1,' LAYRS=',I2,' MCOR=',I3,/,' MMAX=',I3,' NCOR=' 

 1162 4 ,I3,' NMAX=',I3,' NUMOBC=',I2, 

 1163 7 ' NUMRIV=',I2,' NUMBXY=',I4) 

 1164 C FORMAT VARIABLES 

 1165 IF(INDEX0.EQ.0)GOTO 245 

 1166 WRITE(IO,180)(JPRNT(I),I=1,13),KPRNT1,KPRNT2,NPRMN 

 1167 180 FORMAT(/,1X,'C.2 PRINT VARIABLES',/,1X,'JPRNT=',13I2, 

 1168 1 ' KPRNT1,2=',2I5,/,1X,'P/O AT SELECTED CELLS: NPRMN=',I3) 

 1169 IF(NPRMN.GT.0)WRITE(IO,190)(IPRMN(J),J=1,NPRMN) 

 1170 190 FORMAT(1X,' IPRMN=',20I7) 

 1171 IF(ISLICE.EQ.0)GOTO 220 

 1172 WRITE(IO,195)ISLICE 

 1173 195 FORMAT(1X,'SLICE PRINT SECTIONS: ISLICE=',I2) 

 1174 DO 200 I=1,ISLICE 

 1175 JS=JSLICE(I) 

 1176 DO 197 J=1,JS 

 1177 197 NUM(J)=1000*MSLICE(J,I)+NSLICE(J,I) 

 1178 200 WRITE(IO,210)JS,(NUM(J),J=1,JS) 

 1179 210 FORMAT(1X,' JSLICE=',I2,' M,NSLICE=',5I7,/,10I7,/,10I7) 

 1180 WRITE(IO,212)IGPH,NSTGPH,IGPHOP 

 1181 212 FORMAT(1X,'VARIABLES SAVED FOR GRAPHING: IGPH=',I2, 

 1182 1 ' NSTGPH=',I3,' IGPHOP=',i1) 

 1183 I=1 

 1184 IF(IGPH.GT.0)WRITE(IO,216)(I,LGPH(I),MGPH(I),NGPH(I), 

 1185 1 ITYP(I),PTITLE(ITYP(I)),I=1,IGPH) 

 1186 216 FORMAT(11X,I2,': L=',I2,' M=',I3,' N=',I3,' ITYP=',I2, 

 1187 1 ' (',A10,')') 

 1188 220 CONTINUE 

 1189 245 CONTINUE 

 1190 C 

 1191 C WRITE THE SECONDARY PARAMETERS 

 1192 AHMAX=DL**2/(8.*DTE) 

 1193 C CHECK MAXIMUM TIME STEP FOR EXTERNAL, INTERNAL MODES 

 1194 DTEMAX=DL/SQRT(DMAX*AG) 

 1195 DHMAX=DHAH*AHMAX/FLOAT(ISPLIT) 

 1196 WRITE(IO,102)COR,DENRAT,DFDM,DFDN,DMAX,DMIN,DQ, 

 1197 1 DTI,IHR,KRIVBC,NBCEL,NCELL,NSTET,NSTIT,NSTIMX,RAD 

 1198 102 FORMAT(/,1X,'D. PARAMETERS COMPUTED FROM INPUT DATA:',/, 

 1199 1 ' COR=',F8.6,' DENRAT=',F7.5,' DFDM=',E8.2, 

 1200 2 ' DFDN=',E8.2,/,' DMAX=',F8.2,' DMIN=',F8.2,' DQ=',F5.3, 

 1201 3 ' DTI=',F7.1,' IHR=',I3,' KRIVBC=',I1,/, 

 1202 4 ' NBCEL=',I3,' NCELL=',I6, 

 1203 5 ' NSTET=',I9,' NSTIT=',I9,' NSTIMX=',I5,' RAD=',F10.8) 

 1204 SUM1=0.0 

 1205 DO 115 L=1,LBOT 

 1206 115 SUM1=SUM1+CI(L) 

 1207 WRITE(IO,120)(CI(L),L=1,2 ),SUM1 

 1208 120 FORMAT(1X,'CI(1)=',F6.4,' CI(2)=',F6.4,' SUM OF LBOT CIs= ',F4.2) 

 1209 C 

 1210 IF(INDEX0.EQ.0)GOTO 300 

 1211 DTEMAX=DL/SQRT(2.*DMAX*AG) 

 1212 DTIMAX=(DMIN*DQ)**2/(2.*AV00) 

 1213 F=3600./DTI 

 1214 WRITE(IO,160)DTEMAX,DTIMAX,F 

 1215 160 FORMAT(/,1X,'E. CHECKS',/, 

 1216 2 2X,'TIMESTEPS: DTEMAX= DL/SQRT(DMAX*AG)= ',F11.2,/, 

 1217 3 13X,'DTIMAX=(DMIN*DQ)**2/(8*AV00)=',F10.2,/ 

 1218 4 13X,'IHR (STEPS PER HOUR)=3600/DTI=',F12.6) 

 1219 WRITE(IO,166)KONCEN,ICOUPL,IBETAP 

 1220 166 FORMAT(2X,'DENSITY: KONCEN=',I1,' ICOUPL=',I1,' IBETAP=',I1) 

 1221 170 CONTINUE 

 1222 300 CONTINUE 

 1223 700 CONTINUE 

 1224 RETURN 

 1225 END 

 1226 C 

 1227 C----------------------------------------------------------------------- 

 1228 C 

 1229 SUBROUTINE PRNBCG(INDEX) 

 1230 

 1231 C PURPOSE - TO PRINT MOST OF THE RUN PARAMETERS IN A COMPACT FOR 

 1232 C VARIABLES - 
34

 1233 C INDEX = PARAMETER TO SPECIFY PRINTOUT OF SECONDARY 

 1234 C VARIABLES LIKE DEPTHS (0=NO, 1=YES). USUALLY 

 1235 C INDEX=1 AT START OF RUN, 0 LATER. 

 1236 INCLUDE 'COMM20.FOR' 

 1237 DIMENSION TITLX(3),DAVG(NPMSIZ),NUMM(NPMSIZ), 

 1238 1 NUMN(NPMSIZ),NMBRM(MSIZE),NMBRN(NSIZE),ICELL(5),JFIELD(NSIZE) 

 1239 CHARACTER*10 TITLX 

 1240 CHARACTER*2 TITLY(3) 

 1241 CHARACTER*1 ANUM(3*NSIZE) 

 1242 DATA TITLY/'D.',' ',' '/ 

 1243 DATA TITLX/'AREA*100. ','BX*100. ','BY*100. '/ 

 1244 DATA ICELL/5*0/ 

 1245 C PRINT INPUT DATA 

 1246 IF(INDEX.NE.1)RETURN 

 1247 WRITE(IO,100) 

 1248 100 FORMAT(//,1X,'II. TIME-VARIABLE INPUT',55(1H-),/1X, 

 1249 1 'A. REFERENCE DATE ') 

 1250 C ENVIRONMENTAL DATA 

 1251 110 WRITE(IO,120)IYEAR,MONTH,IDAY,IHOUR,IMIN,UT0 

 1252 120 FORMAT(1X,'STARTING DATE: IYEAR=',I4,' MONTH=',I2,' IDAY=',I2, 

 1253 1 ' IHOUR=',I4,' IMIN=',I3,' UTC0=',F10.4) 

 1254 C PRINT WATER LEVEL DATA (TIDES) 

 1255 WRITE(IO,150)NSIGT 

 1256 150 FORMAT(/1X,'B. OCEAN WATER LEVEL DATA: NSIGT=',I2) 

 1257 IF(NSIGT.GT.0)THEN 

 1258 DO I=1,2 

 1259 WRITE(IO,180)I,YTID(I),DTID(I),(TDLEV(I,N),N=1,NSIGT) 

 1260 180 FORMAT(5X,'RECORD=',I2,F8.1,F10.4,20F10.2) 

 1261 ENDDO 

 1262 ENDIF 

 1263 C PRINT WINDS AND AIR TEMPERATURE 

 1264 WRITE(IO,170)NSIGW 

 1265 170 FORMAT(/1X,'C. WIND DATA: NSIGW=',I2) 

 1266 C PRINT RIVER FLOW 

 1267 WRITE(IO,190)NSIGR 

 1268 190 FORMAT(/1X,'D. RIVER FLOW RATE DATA: NSIGR=',I2) 

 1269 IF(NSIGR.GT.0)THEN 

 1270 DO I=1,2 

 1271 WRITE(IO,180)I,YRIV(I),DRIV(I),(QRIV(I,N),N=1,NSIGR) 

 1272 ENDDO 

 1273 ENDIF 

 1274 C PRINT OCEAN BOUNDARY SALINITY 

 1275 WRITE(IO,210)NSIGS 

 1276 210 FORMAT(/,1X,'E. OCEANIC BOUNDARY SALINITY: NSIGS=',I2) 

 1277 IF(NSIGS.GT.0)THEN 

 1278 DO I=1,2 

 1279 WRITE(IO,180)I,YSAL(I),DSAL(I),(SALOCN(I,N),N=1,NSIGS) 

 1280 ENDDO 

 1281 ENDIF 

 1282 C PRINT OCEAN BOUNDARY TEMPERATURE 

 1283 WRITE(IO,230)NSIGTO 

 1284 230 FORMAT(/,1X,'F. OCEANIC BOUNDARY TEMPERATURE: NSIGTO=',I2) 

 1285 IF(NSIGTO.GT.0)THEN 

 1286 DO I=1,2 

 1287 WRITE(IO,180)I,YOTP(I),DOTP(I),(TMPOCN(I,N),N=1,NSIGTO) 

 1288 ENDDO 

 1289 ENDIF 

 1290 C PRINT RIVER BOUNDARY TEMPERATURE 

 1291 WRITE(IO,250)NSIGRT 

 1292 250 FORMAT(/,1X,'G. RIVER BOUNDARY TEMPERATURE: NSIGRT=',I2) 

 1293 IF(NSIGRT.GT.0)THEN 

 1294 DO I=1,2 

 1295 WRITE(IO,180)I,YRVT(I),DRVT(I),(TRIV(I,N),N=1,NSIGRT) 

 1296 ENDDO 

 1297 ENDIF 

 1298 C PRINT ADDITIONAL MET DATA 

 1299 WRITE(IO,260)NSIGM 

 1300 260 FORMAT(/,1X,'H. ADDITIONAL MET DATA: NSIGM=',I2) 

 1301 IF(NSIGM.GT.0)THEN 

 1302 DO I=1,2 

 1303 WRITE(IO,180)I,YMET(I),DMET(I),(VMET(I,N),N=1,NSIGM) 

 1304 ENDDO 

 1305 ENDIF 

 1306 

 1307 c BOUNDARY LOCATIONS 

 1308 IF(NUMOBC+NUMRIV.GT.0)WRITE(IO,410) 

 1309 410 FORMAT(/,1X,'BOUNDARY SPECIFICATIONS IN GEO FILE') 

 1310 IF(NUMOBC.GT.0)THEN 

 1311 DO 420 N=1,NUMOBC 

 1312 420 WRITE(IO,430)N,MB1(N),MB2(N),NB1(N),NB2(N),ITPO(N),JTPO(N), 

 1313 1 ISET1(N),ISET2(N) 

 1314 430 FORMAT(1X,'OCEAN BND. ',I2,' MB1,2=',2I4,' NB1,2=',2I4, 

 1315 1 ' ITPO=',I2,' JTPO=',I2,' ISET1,2=',2i4) 

 1316 ENDIF 

 1317 IF(NUMRIV.GT.0)THEN 

 1318 DO 440 N=1,NUMRIV 

 1319 440 WRITE(IO,450)N,MR1(N),MR2(N),NR1(N),NR2(N),ITPR(N),JTPR(N), 

 1320 1 ISETR(N) 

 1321 450 FORMAT(1X,'RIVER BND. ',I2,' MR1,2=',2I4,' NR1,2=',2I4, 

 1322 1 ' ITPR=',I2,' JTPR=',I2,' ISETR=',I2) 

 1323 ENDIF 

 1324 C CATEGORIES OF IFIELD VARIABLES 

 1325 480 DO 490 N=1,NMAX 

 1326 490 NMBRN(N)=N 

 1327 DO 492 M=1,MMAX 

 1328 492 NMBRM(M) = M 

 1329 DO 495 M=1,MMAX 

 1330 DO 495 N=1,NMAX 

 1331 IF(IFIELD(N,M).LT.10)ICELL(1)=ICELL(1)+1 

 1332 IF(IFIELD(N,M)/10.EQ.1)ICELL(2)=ICELL(2)+1 

 1333 IF(IFIELD(N,M)/10.EQ.2)ICELL(3)=ICELL(3)+1 

 1334 IF(IFIELD(N,M)/10.EQ.KOCNBC)ICELL(4)=ICELL(4)+1 

 1335 IF(IFIELD(N,M)/10.EQ.KOCNBC+1)ICELL(5)=ICELL(5)+1 

 1336 495 CONTINUE 

 1337 ISUM=0 

 1338 DO 496 I=1,5 

 1339 496 ISUM=ISUM+ICELL(I) 

 1340 JSUM=NMAX*MMAX 

 1341 C PRINT IFIELD 

 1342 KP1=KOCNBC+1 

 1343 WRITE(IO,500)KOCNBC,KP1,BSNANG,BSNLAT,BSNLON,DL,MCOR,NCOR 

 1344 500 FORMAT(//,1X,'III. GEOGRAPHY DATA',60(1H-),//, 

 1345 1 1X,'A. IFIELD CELL CODES:',/,4X, 

 1346 2' LAND=0 TRIANGULAR=10 WATER=20 OCEAN BND=',I1,'0 RIVER BND=', 

 1347 3 I1,'0',/,1X,' WATER & NO X-FLOW=21', 

 1348 4 4X,' WATER & NO Y-FLOW=22 WATER & NO X- OR Y-FLOW=23',/, 

 1349 5 1X,' BSNANG=',F8.3,' BSNLAT=',F8.3,' BSNLON=',F8.3,' DL=', 

 1350 6 F9.2,' MCOR=',I2,' NCOR=',I2) 

 1351 WRITE(IO,510)(ICELL(J),J=1,5),ISUM,JSUM 

 1352 510 FORMAT(/,1X,'CELL COUNTS: LAND=',I6,/,2X,'WATER:TRIANGULAR=',I6,/, 

 1353 1 6X,'WATER:SQUARE=',I6,/,9X,'OCEAN BND=',I6,/,9X,'RIVER BND=',I6, 

 1354 2 /,10X,'CELL SUM=',I6,' VS. NMAX*MMAX=',I6) 

 1355 C 

 1356 C PRINT DEPTHS 

 1357 530 NPERL=24 

 1358 KMAX=1+(NMAX-1)/NPERL 

 1359 WRITE(IO,531) 

 1360 531 FORMAT(/,1X,'C. DEPTHS (M) AT MSL') 

 1361 DO 563 K=1,KMAX 

 1362 N1=1+(K-1)*NPERL 

 1363 N2=MIN0(NMAX,N1+NPERL-1) 

 1364 WRITE(IO,532)(NMBRN(N),N=N1,N2) 

 1365 532 FORMAT(2X,' M N=',I2,30I3) 

 1366 DO 550 M=1,MMAX 

 1367 DO 540 N=N1,N2 

 1368 NUMN(N)=-1 

 1369 540 IF(IFIELD(N,M).GT.0)NUMN(N)=D(N,M) 

 1370 WRITE(IO,560)M,(NUMN(N),N=N1,N2) 

 1371 560 FORMAT(1X,I3,2X,30I3) 

 1372 550 CONTINUE 

 1373 563 CONTINUE 

 1374 

 1375 C COMPUTE AVERAGE DEPTHS 

 1376 DO 570 M=1,MMAX 

 1377 NUMN(M)=M 

 1378 NN=0 

 1379 SUM=0. 

 1380 DO 565 N=1,NMAX 

 1381 IF(D(N,M).LT.E)GOTO 565 

 1382 NN=NN+1 

 1383 SUM=SUM+D(N,M) 

 1384 565 CONTINUE 

 1385 570 DAVG(M)=SUM/(E+FLOAT(NN)) 

 1386 WRITE(IO,580) 

 1387 580 FORMAT(/,1X,'MEAN OF NON-ZERO DEPTHS') 

 1388 NPL=5 

 1389 KMAX=1+(MMAX-1)/NPL 

 1390 DO 600 K=1,KMAX 

 1391 M1=1+(K-1)*NPL 

 1392 M2=MIN0(MMAX,M1+NPL-1) 

 1393 595 WRITE(IO,591)(NUMN(M),DAVG(M),M=M1,M2) 

 1394 c591 FORMAT(1X,4(' ','M=',I3,' D=',F8.2,' ')) 

 1395 591 FORMAT(1X,'M,D=',5(I3,F8.2,2x)) 

 1396 600 CONTINUE 

 1397 

 1398 C VARIABLE WIDTHS 

 1399 IF(NUMBXY.LE.0)GOTO 660 

 1400 N3MAX=3*NMAX 

 1401 DO 650 J=1,3 

 1402 WRITE(IO,610)TITLY(J),TITLX(J) 

 1403 610 FORMAT(/,1X,A2,' VARIABLE-WIDTH PARAMETERS: ',A10) 

 1404 NPL=25 ! number per line 

 1405 KMAX=1+(NMAX-1)/NPL 

 1406 DO 640 K=1,KMAX 

 1407 N1=1+NPL*(K-1) 

 1408 N2=MIN0(NMAX,N1+NPL-1) 

 1409 WRITE(IO,612)(NMBRN(N),N=N1,N2) 

 1410 612 FORMAT(4x,40I3) 

 1411 DO 630 M=1,MMAX 

 1412 DO 620 N=N1,N2 

 1413 IF(J.EQ.1)F1=AREA(N,M) 

 1414 IF(J.EQ.2)F1=BX(N,M) 

 1415 IF(J.EQ.3)F1=BY(N,M) 

 1416 JFIELD(N)=IFIELD(N,M) 

 1417 620 NUMN(N)=F1*100. 

 1418 CALL PRNCHR(3,NUMN,JFIELD,ANUM,NMAX) 

 1419 N1A=1+3*(N1-1) 

 1420 N2A=MIN0(3*NMAX,N1A-1+3*NPL) 

 1421 WRITE(IO,635)M,(ANUM(N),N=N1A,N2A) 

 1422 635 FORMAT(1X,I3,120A1,3(/5X,120A1)) 

 1423 630 CONTINUE ! end mmax 

 1424 640 CONTINUE ! end k 

 1425 650 CONTINUE ! end j 

 1426 660 CONTINUE 

 1427 C PRINT FLAGS 

 1428 DO 670 N=1,NSIZE 

 1429 670 NUMN(N)=N 

 1430 C WRITE OUT THE TAGS 

 1431 NX=MAX0(1,NCOL,NROW) 

 1432 WRITE(IO,675) 

 1433 675 FORMAT(/,1X,'E. ROW/COLUMN FLAGS:',/,6X,'B.C. FOR IL/IR: 0=WATER', 

 1434 1 ' LEVEL, 1=FLOWRATE, 2=ZERO FLOW',/,12X,2('ICOL',14X,'IROW' 

 1435 c 2 ,18X),/,2X,2(' I',(4X,'N MA MB IL IR',4X,' M NA NB IL IR',3X))) 

 1436 2 ,18X),/,2X,2(' I',(4X,'N MA MB L R',4X,' M NA NB L R',3X))) 

 1437 NXM=1+(NX-1)/2 

 1438 DO 680 N=1,NXM 

 1439 M=N+NXM 

 1440 680 WRITE(IO,690)N,(ICOL(K,N),K=1,5),(IROW(K,N),K=1,5),M, 

 1441 1 (ICOL(K,M),K=1,5),(IROW(K,M),K=1,5) 

 1442 690 FORMAT(1X,2(I3,':',3I4,2I2,2X,3I4,2I2,2X)) 

 1443 C PRINT OUT NEW IFIELD (WITH BARRIERS) 

 1444 NPL=30 ! number per line 

 1445 KMAX=1+(NMAX-1)/NPL 

 1446 DO 730 K=1,KMAX 

 1447 N1=1+NPL*(K-1) 

 1448 N2=MIN0(NMAX,N1+NPL-1) 

 1449 WRITE(IO,692)(NUMN(I),I=N1,N2) 

 1450 692 FORMAT(/,1X,'F. MODIFIED IFIELD',/,1X,' M NA NB ',40I2, 

 1451 1 3(/10X,40I2)) 

 1452 DO 700 M=1,MMAX 

 1453 NA=NAB(M)/1000 

 1454 NB=MOD(NAB(M),1000) 

 1455 700 WRITE(IO,710)M,NA,NB,(IFIELD(I,M),I=N1,N2) 

 1456 710 FORMAT(1X,I3,2I4,2X,40I2,3(/14X,40I2)) 

 1457 730 CONTINUE 

 1458 

 1459 DO 780 K=1,KMAX 

 1460 N1=1+NPL*(K-1) 

 1461 N2=MIN0(NMAX,N1+NPL-1) 

 1462 WRITE(IO,750)(NUMN(I),I=N1,N2) 

 1463 750 FORMAT(/,1X,'MFLUX',/,6X,40I2) 

 1464 DO 760 M=1,MMAX 

 1465 760 WRITE(IO,770)M,(MFLUX(I,M),I=N1,N2) 

 1466 770 FORMAT(1X,I3,2X,40I2) 

 1467 780 CONTINUE 

 1468 

 1469 DO 820 K=1,KMAX 

 1470 N1=1+NPL*(K-1) 

 1471 N2=MIN0(NMAX,N1+NPL-1) 

 1472 WRITE(IO,800)(NUMN(I),I=N1,N2) 

 1473 800 FORMAT(/,1X,'NFLUX',/,6X,40I2) 

 1474 DO 810 M=1,MMAX 

 1475 810 WRITE(IO,770)M,(NFLUX(I,M),I=N1,N2) 

 1476 820 CONTINUE 

 1477 RETURN 

 1478 END 

 1479 C 

 1480 C-------------------------------------------------------------------------

 1481 C 

 1482 SUBROUTINE PSLICE 

 1483 C JANUARY 1985 K. W. HESS MEAD VAX 11/750 

 1484 C PURPOSE - PRINT ALL CONCENTRATIONS OVER DEPTH AT ALL GRID CELLS 
35

 1485 C ALONG A SLICE OF THE DOMAIN. UP TO 

 1486 C 5 SLICES ALLOWED, EACH WITH UP TO 10 POINTS. 

 1487 C VARIABLES - 

 1488 C ISLICE = NO. OF SLICES 

 1489 C ITYPE = TYPE OF VARIABLE 

 1490 C JSLICE(I) = NO. OF POINTS IN I-TH SLICE 

 1491 C MSLICE(I,J) = J-TH VALUE OF THE M-GRID POINT ON THE I-TH SLICE 

 1492 INCLUDE 'COMM20.FOR' 

 1493 DIMENSION NO(NM2SIZ),MO(NM2SIZ),NDAT(LSIZE,NM2SIZ),II(NM2SIZ), 

 1494 1 PSE(NM2SIZ),DP(NM2SIZ),F(LSIZE,NM2SIZ),IITYPE(8) 

 1495 DATA IITYPE/4,5,6, 9,10, 22,15,16/ ! UT,VT,W, S,T, AH3,AV,DV 

 1496 CHARACTER*5 ANUM(NM2SIZ),BNUM(NM2SIZ) 

 1497 DO 100 N=1,NM2SIZ 

 1498 II(N)=N 

 1499 ANUM(N)='=====' 

 1500 100 BNUM(N)='-----' 

 1501 C LOOP THRU DATA 

 1502 IF(ISLICE.LE.0)RETURN 

 1503 C LOOP THRU THE SLICES 

 1504 DO 300 IS=1,ISLICE 

 1505 C CONSTRUCT THE SLICE 

 1506 K=0 

 1507 DO 130 J=1,JSLICE(IS)-1 

 1508 NA=NSLICE(J,IS) 

 1509 MA=MSLICE(J,IS) 

 1510 NB=NSLICE(J+1,IS) 

 1511 MB=MSLICE(J+1,IS) 

 1512 C GET DIRECTION (INCREASING OR DECREASING) 

 1513 MDIR=ISIGN(1,MB-MA) 

 1514 NDIR=ISIGN(1,NB-NA) 

 1515 IF(NB.EQ.NA)NDIR=0 

 1516 IF(MB.EQ.MA)MDIR=0 

 1517 C LINE: save m, n, and depth 

 1518 NN=NA-NDIR 

 1519 MM=MA-MDIR 

 1520 110 MM=MM+MDIR 

 1521 NN=NN+NDIR 

 1522 IF(K.GT.1.AND.(MM.EQ.MO(K).AND.NN.EQ.NO(K)))GOTO 110 

 1523 K=K+1 

 1524 DP(K)=D(NN,MM) 

 1525 PSE(K)=SE(NN,MM) 

 1526 MO(K)=MM 

 1527 NO(K)=NN 

 1528 IF(MM.EQ.MB.AND.NN.EQ.NB)GOTO 130 

 1529 GOTO 110 

 1530 130 CONTINUE 

 1531 KMAX=K 

 1532 C LOOP THRU THE VARIABLES 

 1533 DO 270 IT=1,8 

 1534 LEVS=LBOT 

 1535 IF(IITYPE(IT).EQ.6)LEVS=LAYRS 

 1536 IF(IITYPE(IT).GE.15.AND.IITYPE(IT).LE.17)LEVS=LAYRS 

 1537 FMAX=0. 

 1538 DO 140 L=1,LEVS 

 1539 DO 140 K=1,KMAX 

 1540 F(L,K)=SELECT(IITYPE(IT),L,NO(K),MO(K)) 

 1541 140 FMAX=AMAX1(ABS(F(L,K)),FMAX) 

 1542 c scale 

 1543 I1=0 

 1544 IF(FMAX.GT.0)I1=INT(ALOG10(FMAX)+10.)-13 

 1545 SCL=10.**I1 

 1546 DO 145 L=1,LEVS 

 1547 DO 145 K=1,KMAX 

 1548 145 NDAT(L,K)=NINT(F(L,K)/SCL) 

 1549 c loop thru sets 

 1550 KPERL=14 

 1551 KSET=(KMAX-1)/KPERL+1 

 1552 DO KS=1,KSET 

 1553 C WRITE OUT THE HEADER LINE 

 1554 IF(KS.EQ.1)WRITE(IO,150)PTITLE(IITYPE(IT)),SCL,UT,FMAX 

 1555 150 FORMAT(/,1X,'SECTION : ',A10,' DIVIDED BY ',1PE9.3,' UT=', 

 1556 1 0PF10.4,' FMAX=',E10.4) 

 1557 K1=1+KPERL*(KS-1) 

 1558 K2=MIN0(KMAX,K1+KPERL-1) 

 1559 WRITE(IO,152)(II(K),K=K1,K2 ) 

 1560 152 FORMAT(4X,'K=',14I5) 

 1561 WRITE(IO,160)(NO(K),K=K1,K2 ) 

 1562 160 FORMAT(4X,'N=',14I5) 

 1563 WRITE(IO,170)(MO(K),K=K1,K2) 

 1564 170 FORMAT(4X,'M=',14I5) 

 1565 c depths 

 1566 WRITE(IO,210)(DP(K),K=K1,K2) 

 1567 210 FORMAT(2X,' D=',14F5.1) 

 1568 WRITE(IO,220)(PSE(K),K=K1,K2) 

 1569 220 FORMAT(2X,' SE=',14F5.2) 

 1570 WRITE(IO,240)(BNUM(K),K=K1,K2) 

 1571 240 FORMAT(6X,14A5) 

 1572 C RUN DOWN THE COLUMN 

 1573 DO 250 L=1,LEVS 

 1574 250 WRITE(IO,260)L,(NDAT(L,K),K=K1,K2) 

 1575 260 FORMAT(1X,'L=',I2,1X,14I5) 

 1576 WRITE(IO,265)ANUM(1),(ANUM(K),K=K1,K2) 

 1577 265 FORMAT(X,15A5) 

 1578 ENDDO ! end set 

 1579 270 CONTINUE ! end type 

 1580 300 CONTINUE ! end slice 

 1581 RETURN 

 1582 END 

 1583 C 

 1584 C------------------------------------------------------------ 

 1585 C 

 1586 SUBROUTINE PGRAPH 

 1587 C OCTOBER 1984 K. HESS MEAD VAX 11/750 

 1588 C PURPOSE - TO SAVE VARIABLES FOR LATER GRAPHING 

 1589 C VARIABLES - 

 1590 C IO1,IO2 = CHANNEL NUMBERS FOR OUTPUT (20,21). 

 1591 C (SET IN SUB. INITS) 

 1592 INCLUDE 'COMM20.FOR' 

 1593 DIMENSION XGR(NDGPH),NUM(NDGPH) 

 1594 DATA PTITLE/ 

 1595 1 'SE ','UE ','VE ','Utotal ','Vtotal ', 

 1596 2 'W (m/s) ','TSX*1.E+7 ','TSY*1.E+7 ','S (PPT) ','T (C) ', 

 1597 3 'AH/H ','THETA1 ','THETA2 ','THETA3 ','AV ', 

 1598 4 'DV ','RI ','WX ','WY ','UHOLD/H ', 

 1599 5 'VHOLD/H ','AH3/H ',' ',' ',' '/ 

 1600 C CHECK FOR NUMBER OF GRAPHING VARIABLES 

 1601 IF(IGPH.LE.0)RETURN 

 1602 C CHECK FOR WRITE: 

 1603 IF(.NOT.(NSTI.EQ.0.OR.NSTI.EQ.NSTIMX.OR.NSTI.EQ.NSTGPH*(NSTI/ 

 1604 1 NSTGPH)))GOTO 210 

 1605 C STORE PRESENT VALUES IN ARRAY "XGR" 

 1606 DO 110 I=1,IGPH 

 1607 IF(I.GT.NDGPH)GOTO 110 

 1608 NUM(I)=I 

 1609 N=NGPH(I) 

 1610 M=MGPH(I) 

 1611 L=LGPH(I) 

 1612 XGR(I)=SELECT(ITYP(I),L,N,M) 

 1613 110 CONTINUE 

 1614 C LOOP THRU VARIABLES 

 1615 NUMPLN=IGPH 

 1616 KMAX=1+(IGPH-1)/NUMPLN 

 1617 DO 200 K=1,KMAX 

 1618 J1=1+NUMPLN*(K-1) 

 1619 J2=MIN0(J1+NUMPLN-1,IGPH) 

 1620 C WRITE HEADER: IGXX=FORMAT, IV=INTVEL, NKOLS=NO. COLUMNS HERE 

 1621 IF(NSTI.GT.0.OR.IGPHOP.EQ.0)GOTO 125 

 1622 IGXX=3 

 1623 NKOLS=1+J2-J1 

 1624 WRITE(LUGRF,112)CTITLE,IGPH,NSTIMX,NSTGPH,DTI,YEAR 

 1625 112 FORMAT(8A10,/,1X,3I7,F9.3,2F9.3) 

 1626 DO 115 J=J1,J2 

 1627 115 WRITE(LUGRF,120)J,PTITLE(ITYP(J)),LGPH(J),MGPH(J),NGPH(J) 

 1628 120 FORMAT(2X,'COLUMN ',I3,' HAS ',A10,6H AT L=,I2,3H M=,I3,3H N=,I3) 

 1629 WRITE(LUGRF,124)(NUM(I),I=J1,J2) 

 1630 124 FORMAT(4X,'YEAR UT',40I11) 

 1631 C PRINT THE VALUES (UP TO 40) 

 1632 125 WRITE(LUGRF,190)YEAR,UT,(XGR(J),J=J1,J2) 

 1633 190 FORMAT(1X,F6.0,F9.4,40(x,F10.4)) 

 1634 C WRITE NUMBERS AT END 

 1635 200 IF(NST.EQ.NSTMAX.AND.IGPHOP.EQ.1)WRITE(LUGRF,124)(NUM(I), 

 1636 1 I=J1,J2) 

 1637 210 RETURN 

 1638 END 

 1639 C 

 1640 C---------------------------------------------------------- 

 1641 C 

 1642 FUNCTION SELECT(ITYPE,L,N,M) 

 1643 C SELECT VARIABLE BASED ON THE GRAPHING TABLE VALUES 

 1644 c IGPH ranges from 1 to 21 

 1645 INCLUDE 'COMM20.FOR' 

 1646 SELECT=0.0 

 1647 MP=MIN0(M+1,MMAX) 

 1648 NP=MIN0(N+1,NMAX) 

 1649 GOTO(100,110,120,130,140,150,160,170,180,190,200,210, 

 1650 1 220,230,240,250,260,270,280,290,300,310),ITYPE 

 1651 GOTO 400 

 1652 100 SELECT=SE(N,M) ! 1 

 1653 GOTO 400 

 1654 110 SELECT=UE(N,M) 

 1655 GOTO 400 

 1656 120 SELECT=VE(N,M) ! 3 

 1657 GOTO 400 

 1658 130 SELECT=UE(N,M)+U(L,N,M) 

 1659 GOTO 400 

 1660 140 SELECT=VE(N,M)+V(L,N,M) ! 5 

 1661 GOTO 400 

 1662 150 SELECT=W(L,N,M) 

 1663 GOTO 400 

 1664 160 SELECT=TSX(N,M)*1.E+7 ! 7 

 1665 GOTO 400 

 1666 170 SELECT=TSY(N,M)*1.E+7 

 1667 GOTO 400 

 1668 180 SELECT=S(L,N,M) 

 1669 GOTO 400 

 1670 190 SELECT=T(L,N,M) ! 10 

 1671 GOTO 400 

 1672 200 SELECT=AH(N,M)/(D(N,M)+SE(N,M)+E) 

 1673 GOTO 400 

 1674 210 SELECT=THETA1(N,M) ! 12 

 1675 GOTO 400 

 1676 220 SELECT=THETA2(N,M) 

 1677 GOTO 400 

 1678 230 SELECT=THETA3(N,M) 

 1679 GOTO 400 

 1680 240 SELECT=AV(L,N,M)*1.E+4 ! 15 

 1681 GOTO 400 

 1682 250 SELECT=DV(L,N,M)*1.E+4 

 1683 GOTO 400 

 1684 260 SELECT=RI(L,N,M) 

 1685 GOTO 400 

 1686 270 SELECT=WX(N,M) ! 18 

 1687 GOTO 400 

 1688 280 SELECT=WY(N,M) 

 1689 GOTO 400 

 1690 290 SELECT=UHOLD(N,M)/(D(N,M)+SE(N,M)+D(N,MP)+SE(N,MP)) ! 20 

 1691 GOTO 400 

 1692 300 SELECT=VHOLD(N,M)/(D(N,M)+SE(N,M)+D(NP,M)+SE(NP,M)) ! 21 

 1693 GOTO 400 

 1694 310 SELECT=AH3(L,N,M)/(D(N,M)+SE(N,M)+E) ! 22 

 1695 400 CONTINUE 

 1696 RETURN 

 1697 END 

 1698 C======================================================================= 

 1699 C MECCA FILE : EXMODE.FOR 

 1700 C----------------------------------------------------------------------- 

 1701 C 

 1702 SUBROUTINE EXMODE 

 1703 C JANUARY 1986 K.W. HESS MEAD VAX 11/750 

 1704 C PURPOSE - TO COMPUTE EXTERNAL-MODE FLOWRATES AND WATER LEVELS 

 1705 C FROM REVISED EQUATIONS FOR VARIABLE GRID WIDTH (TO 

 1706 C MODEL NARROW RIVER WIDTHS). 

 1707 INCLUDE 'COMM20.FOR' 

 1708 c UPDATE THETA FUNCTIONS 

 1709 CALL THETAS 

 1710 C SET THE BOUNDARY CONDITIONS 

 1711 CALL BNDRY1 

 1712 C UPDATE HORIZONTAL VISCOSITY COEFFICIENTS 

 1713 CALL HORVIS 

 1714 C STORE PREVIOUS WATER LEVELS FOR THE SALINITY AND TEMP. CALCS. 

 1715 IF(NSTE.GT.1)GOTO 150 

 1716 DO 130 N=1,NMAX 

 1717 DO 130 M=1,MMAX 

 1718 UHOLD(N,M)=UH(N,M) 

 1719 VHOLD(N,M)=VH(N,M) 

 1720 130 SOLD(N,M)=SE(N,M) 

 1721 150 CONTINUE 

 1722 C COMPUTE VELOCITIES 

 1723 CALL UHVH 

 1724 RETURN 

 1725 END 

 1726 C 

 1727 C----------------------------------------------------------------------- 

 1728 C 

 1729 SUBROUTINE BNDRY1 

 1730 C OCTOBER 1984 K. W. HESS MEAD VAX11/750 

 1731 C PURPOSE - TO SET THE EXTERNAL-MODE OPEN BOUNDARY WATER LEVEL OR 

 1732 C FLOWRATE CONDITIONS. 

 1733 C VARIABLES - 

 1734 C VAL = TIDAL ELEVATION/FLOWRATE AT ENDS OF OCEAN BOUNDARY

 1735 C FT = TIME PAST PREVIOUS HI/LO (HR) 

 1736 C IS = GRID INCREMENT FOR RADIATION TO SET VELOCITY AT 
36

 1737 C OUTSIDE EQUAL TO VELOCITY IN INTERIOR. 

 1738 C ITPO = DIRECTION OF OUTFLOW: 1=X, -1=-X, 2=Y, -2=-Y 

 1739 C JTPO = TYPE OF OCEAN BOUNDARY CONDITION 

 1740 C 1 : WATER LEVEL SPECIFICATION 

 1741 C 2 : TRANSPORT OUTFLOW 

 1742 C 3 : ORLANSKI RADIATION OUTFLOW (REQUIRES WL) 

 1743 C 4 : REIMANN INVARIENT RADIATION OUTFLOW (REQUIRES

 1744 C ITPR = DIRECTION OF RIVER INFLOW: 1=X, -1=-X, 2=Y, -2=-Y 

 1745 C JTPR = RIVERINE CONDITION: 1=FLUME, 2=WATER FALLS 

 1746 C J = GRID INCREMENT FOR TIDES TO SET VELOCITY AT 

 1747 C OUTSIDE EQUAL TO VELOCITY IN INTERIOR. 

 1748 C NUMOBC = NUMBER OF TIDAL BOUNDARIES 

 1749 C QRIV = RIVER FLOWRATE (M**3/S) 

 1750 INCLUDE 'COMM20.FOR' 

 1751 DIMENSION FINAL(NDTID2),QRATE(NDRIV2) 

 1752 C1=DTE/DL 

 1753 ITEST=IPRNT1 

 1754 IF(NSTI.GT.10.AND.NSTE.GT.1)ITEST=0 

 1755 IF(ITEST.GT.0)WRITE(ISCR,100)UT,NSTI,NSTE,NUMOBC,NUMRIV 

 1756 100 FORMAT(/,X,'BNDRY1 : UT=',F10.4,' NSTI=',I6,' NSTE=',I2, 

 1757 1 ' NUMOBC=',i2,' NUMRIV=',I2) 

 1758 RAMPT=AMIN1(1.0,CUMDAY) 

 1759 RAMPR=AMIN1(1.0,CUMDAY) 

 1760 IF(NUMOBC.LE.0)GOTO 220 

 1761 C LOOP THRU OCEANIC BOUNDARIES 

 1762 DO 200 IB=1,NUMOBC 

 1763 C FIND THE LATEST VALUES FROM INPUT DATA 

 1764 CALL RR(YT,ISCR,LUTID,IENDTD,DTID,YTID,NSIGT,NDTID2,TDLEV,FINAL) 

 1765 F1=ISIGN(1,ITPO(IB)) 

 1766 IUH=-(ISIGN(1,ITPO(IB))+1)/2 

 1767 ISE=-ISIGN(1,ITPO(IB)) 

 1768 IDIR=IABS(ITPO(IB)) 

 1769 IF(ITEST.GT.0)WRITE(ISCR,110)IB,F1,ISE,IUH,IDIR,JTPO(IB),FINAL(IB) 

 1770 110 FORMAT(X,'IB=',I2,' F1,ISE,IUH,IDIR,JTPO=',F4.1,4I3, 

 1771 1 ' VAL=',E12.4) 

 1772 C RUN ACROSS BOUNDARY AND SET CONDITIONS 

 1773 KMAX=IABS(MB1(IB)-MB2(IB))+IABS(NB1(IB)-NB2(IB)) 

 1774 K=0 

 1775 DO 200 N=NB1(IB),NB2(IB) 

 1776 DO 200 M=MB1(IB),MB2(IB) 

 1777 K=K+1 

 1778 EL=RAMPT*FINAL(ISET1(IB)) 

 1779 IF(KMAX.GT.0)EL=RAMPT*(FLOAT(K-1)*FINAL(ISET2(IB))+ 

 1780 1 FLOAT(KMAX+1-K)*FINAL(ISET1(IB)))/FLOAT(KMAX) 

 1781 GOTO(120,130,140,150),JTPO(IB) 

 1782 c 1.SIMPLE WATER LEVEL 

 1783 120 SEPP(N,M)=EL 

 1784 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1785 GOTO 190 

 1786 C 2.OUTWARD TRANSPORT 

 1787 130 IF(IABS(ITPO(IB)).EQ.1)THEN 

 1788 UHP(N,M+IUH)=F1*EL 

 1789 SEPP(N,M)=SE(N,M+ISE) 

 1790 ELSE 

 1791 VHP(N+IUH,M)=F1*EL 

 1792 SEPP(N,M)=SE(N+ISE,M) 

 1793 ENDIF 

 1794 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1795 GOTO 190 

 1796 c 3.RADIATION CONDITION, ORLANSKI 

 1797 140 IF(IABS(ITPO(IB)).EQ.2)GOTO 145 

 1798 DELSE=SE(N,M)-SE(N,M+ISE) 

 1799 IF(D(N,M+2*ISE).GT.0.)DELSE=1.5*SE(N,M)-2.*SE(N,M+ISE) 

 1800 1 +.5*SE(N,M+2*ISE) 

 1801 SEPP(N,M)=SE(N,M)-C1*SQRT(E+AG*.5*(D(N,M)+D(N,M+ISE) 

 1802 1 +SE(N,M)+SE(N,M+ISE)))*DELSE 

 1803 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1804 GOTO 190 

 1805 145 DELSE=SE(N,M)-SE(N+ISE,M) 

 1806 IF(D(N+2*ISE,M).GT.0.)DELSE=1.5*SE(N,M)-2.*SE(N+ISE,M) 

 1807 1 +.5*SE(N+2*ISE,M) 

 1808 SEPP(N,M)=SE(N,M)-C1*SQRT(E+AG*.5*(D(N,M)+D(N+ISE,M) 

 1809 1 +SE(N,M)+SE(N+ISE,M)))*DELSE 

 1810 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1811 GOTO 190 

 1812 c 4.RADIATION CONDITION, RIEMANN INVARIENT 

 1813 150 IF(IABS(ITPO(IB)).EQ.2)GOTO 155 

 1814 SEPP(N,M)=EL+F1*UH(N,M+IUH)/SQRT(E+AG*.5*(D(N,M)+D(N,M+ISE) 

 1815 1 +SE(N,M)+SE(N,M+ISE))) 

 1816 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1817 GOTO 190 

 1818 C Y-DIRECTION 

 1819 155 SEPP(N,M)=EL+F1*VH(N+IUH,M)/SQRT(E+AG*.5*(D(N,M)+D(N+ISE,M) 

 1820 1 +SE(N,M)+SE(N+ISE,M))) 

 1821 SEP(N,M)=.5*(SE(N,M)+SEPP(N,M)) 

 1822 190 CONTINUE 

 1823 IF(ITEST.GT.0)WRITE(ISCR,210)N,M,EL,SEPP(N,M) 

 1824 210 FORMAT(3X,'N,M=',2I4,' EL=',F7.4,' SEPP=',F7.4) 

 1825 200 CONTINUE 

 1826 C 

 1827 C RIVER FLOW BOUNDARIES 

 1828 220 IF(NUMRIV.EQ.0)RETURN 

 1829 IF(NSTE.EQ.1.AND.IPRNT1.GT.0)WRITE(ISCR,221)NSTI,NSTE,RAMPR 

 1830 221 FORMAT(1X,'BNDRY1: RIVER BOUNDARIES AT NSTI=',I6,' NSTE=',I6, 

 1831 1 ' RAMPR=',f4.2) 

 1832 CALL RR(YT,ISCR,LURIV,IENDRV,DRIV,YRIV,NSIGR,NDRIV2,QRIV,QRATE) 

 1833 DO N=1,NSIGR 

 1834 RATE(N)=QRATE(ISETR(N))*RAMPR 

 1835 IF(NSTE.EQ.1.AND.IPRNT1.GT.0)WRITE(ISCR,225)N,ITPR(N),JTPR(N), 

 1836 1 ISETR(N),RATE(N) 

 1837 225 FORMAT(1X,'NR=',I2,' ITPR,JTPR=',2i2,' ISETR=',I2, 

 1838 1 ' RATE x RAMPR (m**3/s)=',F12.3) 

 1839 ENDDO 

 1840 DO 350 NR=1,NSIGR 

 1841 IS=0 

 1842 IF(ITPR(NR).LT.0)IS=-1 

 1843 ISS=1+2*IS 

 1844 F1=FLOAT(ISS)/DL 

 1845 DO 350 M=MR1(NR),MR2(NR) 

 1846 DO 350 N=NR1(NR),NR2(NR) 

 1847 IF(JTPR(NR).EQ.1)GOTO 330 

 1848 C WATER FALLS CONDITION 

 1849 SE(N,M)=SE(N,M)+DTE*RATE(NR)/(AREA(N,M)*DL*DL) 

 1850 F2=DTE*RATE(NR)/(AREA(N,M)*DL*DL) 

 1851 IF(NSTE.EQ.1.AND.IPRNT1.GT.0)WRITE(ISCR,*) 

 1852 1 ' WATER FALLS AT N,M=',N,M,' DEL=',F2 

 1853 GOTO 350 

 1854 330 IF(IABS(ITPR(NR)).EQ.2)GOTO 340 

 1855 C INPUT FLOW, X-DIRECTION 

 1856 IBARR=MOD(IFIELD(N,M+IS),10) 

 1857 IF(IBARR.EQ.1.OR.IBARR.EQ.3)GOTO 350 

 1858 IF(NSTE.GT.1)UH(N,M+IS)=UHP(N,M+IS) 

 1859 UHP(N,M+IS)=F1*RATE(NR)/BX(N,M+IS) 

 1860 SEPP(N,M)=SE(N,M+ISS) 

 1861 SE(N,M)=SE(N,M+ISS) 

 1862 GOTO 350 

 1863 C INPUT FLOW, Y-DIRECTION 

 1864 340 IBARR=MOD(IFIELD(N+IS,M),10) 

 1865 IF(IBARR.EQ.2.OR.IBARR.EQ.3)GOTO 350 

 1866 IF(NSTE.GT.1)VH(N+IS,M)=VHP(N+IS,M) 

 1867 VHP(N+IS,M)=F1*RATE(NR)/BY(N+IS,M) 

 1868 SEPP(N,M)=SE(N+ISS,M) 

 1869 SE(N,M)=SE(N+ISS,M) 

 1870 350 CONTINUE 

 1871 360 RETURN 

 1872 END 

 1873 C 

 1874 C----------------------------------------------------------------------- 

 1875 C 

 1876 SUBROUTINE HORVIS 

 1877 C APRIL 1986 K. HESS MEAD VAX-11/750 (REV 9/87) 

 1878 C PURPOSE - TO UPDATE THE HORIZONTAL EDDY VISCOSITY 

 1879 C VARIABLES - 

 1880 C AH(,) = ARRAY TO STORE PRODUCT OF HORIZONTAL 

 1881 C VISCOSITY AND DEPTH, AT GRID CENTER 

 1882 C AH=AH0+CAH*DL*SQRTU2(U,X)**2+2(V,Y)**2+(U,Y+V,X 

 1883 C AH0 = BACKGROUND VISCOSITY 

 1884 C CAH = FACTOR FOR VISCOSITY 

 1885 INCLUDE 'COMM20.FOR' 

 1886 DIMENSION UL(LSIZE,NSIZE,MSIZE),VL(LSIZE,NSIZE,MSIZE) 

 1887 DATA ISMAG,ALFA/2, 1./ 

 1888 c skip if necessary 

 1889 IF(IHVISC.LE.0.OR.MOD(NSTET,IHVISC).NE.0)GOTO 180 

 1890 c save 3-d velocity field 

 1891 DO M=1,MMAX 

 1892 DO N=1,NMAX 

 1893 DO L=1,LBOT 

 1894 UL(L,N,M)=UE(N,M)+ALFA*U(L,N,M) 

 1895 VL(L,N,M)=VE(N,M)+ALFA*V(L,N,M) 

 1896 ENDDO 

 1897 ENDDO 

 1898 ENDDO 

 1899 C LOOP OVER THE INTERIOR CELLS 

 1900 KOCN=10*(KOCNBC-1) 

 1901 DO 120 M=1,MMAX 

 1902 NA=NAB(M)/1000 

 1903 NB=MOD(NAB(M),1000) 

 1904 IF(NA.GT.NB)GOTO 120 

 1905 MM=MAX0(M-1,1) 

 1906 MP=MIN0(M+1,MMAX) 

 1907 DO 110 N=NA,NB 

 1908 IF(IFIELD(N,M).LT.10.OR.IFIELD(N,M).GE.KOCN)GOTO 110 

 1909 NM=MAX0(N-1,1) 

 1910 NP=MIN0(N+1,NMAX) 

 1911 H=D(N,M)+SE(N,M) 

 1912 AH1=0. 

 1913 C INTERIOR CELLS 

 1914 DO 100 L=1,LBOT 

 1915 IF(INTER.EQ.0)GOTO 90 

 1916 IF(ISMAG.EQ.1)THEN 

 1917 DUDY=.25*((UL(L,NP,M)+UL(L,N,M))*AMAX0(NFLUX(N,M),NFLUX(N,MP)) 

 1918 1 -(UL(L,N,M)+UL(L,NM,M))*AMAX0(NFLUX(NM,M),NFLUX(NM,MP)) 

 1919 2 +(UL(L,NP,MM)+UL(L,N,MM))*AMAX0(NFLUX(N,MM),NFLUX(N,M)) 

 1920 3 -(UL(L,N,MM)+UL(L,NM,MM))*AMAX0(NFLUX(NM,MM),NFLUX(NM,M))) 

 1921 DVDX=.25*((VL(L,N,M)+VL(L,N,MP))*AMAX0(MFLUX(N,M),MFLUX(NP,M)) 

 1922 1 -(VL(L,N,M)+VL(L,N,MM))*AMAX0(MFLUX(N,MM),MFLUX(NP,MM)) 

 1923 2 +(VL(L,NM,MP)+VL(L,NM,M))*AMAX0(MFLUX(N,M),MFLUX(NM,M)) 

 1924 3 -(VL(L,NM,M)+VL(L,NM,MM))*AMAX0(MFLUX(N,MM),MFLUX(NM,MM))) 

 1925 ELSE 

 1926 DUDY=.25*(ABS(UL(L,NP,M) -UL(L,N,M)) +ABS(UL(L,N,M) -UL(L,NM,M)) 

 1927 1 +ABS(UL(L,NP,MM)-UL(L,N,MM))+ABS(UL(L,N,MM)-UL(L,NM,MM))) 

 1928 DVDX=.25*(ABS(VL(L,N,M) -VL(L,N,MP))+ABS(VL(L,N,M) -VL(L,N,MM)) 

 1929 1 +ABS(VL(L,NM,MP)-VL(L,NM,M))+ABS(VL(L,NM,M)-VL(L,NM,MM))) 

 1930 ENDIF 

 1931 ARG=2.*(((UL(L,N,M)-UL(L,N,MM)))**2+ 

 1932 1 ((VL(L,N,M)-VL(L,NM,M)))**2)+(DUDY+DVDX)**2 

 1933 C UPDATED VALUE 

 1934 90 AMM=AH0+CAH*DL*SQRT(ARG) 

 1935 IF(AH3(L,N,M).EQ.0.0)AH3(L,N,M)=AMM*H 

 1936 IF(AH3(L,N,M).GT.0.0)AH3(L,N,M)=SQRT(AH3(L,N,M)*AMM*H) 

 1937 100 AH1=AH1+CI(L)*AH3(L,N,M) 

 1938 AH(N,M)=AH1 

 1939 110 CONTINUE 

 1940 120 CONTINUE 

 1941 C BOUNDARY CELLS 

 1942 IF(NUMOBC.LE.0)GOTO 140 

 1943 DO 130 IB=1,NUMOBC 

 1944 IDIR=IABS(ITPO(IB)) 

 1945 IS=-ISIGN(1,ITPO(IB)) 

 1946 DO 130 M=MB1(IB),MB2(IB) 

 1947 DO 130 N=NB1(IB),NB2(IB) 

 1948 H=D(N,M)+SE(N,M) 

 1949 c x-direction 

 1950 IF(IDIR.EQ.1)THEN 

 1951 F1=H/(D(N,M+IS)+SE(N,M+IS)) 

 1952 AH(N,M)=AH(N,M+IS)*F1 

 1953 DO L=1,LBOT 

 1954 AH3(L,N,M)=AH3(L,N,M+IS)*F1 

 1955 ENDDO 

 1956 ENDIF 

 1957 c y-direction 

 1958 IF(IDIR.EQ.2)THEN 

 1959 F2=H/(D(N+IS,M)+SE(N+IS,M)) 

 1960 AH(N,M)=AH(N+IS,M)*F2 

 1961 DO L=1,LBOT 

 1962 AH3(L,N,M)=AH3(L,N+IS,M)*F2 

 1963 ENDDO 

 1964 ENDIF 

 1965 130 CONTINUE 

 1966 C RIVER BOUNDARIES 

 1967 140 IF(NUMRIV.LE.0)GOTO 160 

 1968 DO 150 IB=1,NUMRIV 

 1969 IDIR=IABS(ITPR(IB)) 

 1970 IS=ISIGN(1,ITPR(IB)) 

 1971 DO 150 M=MR1(IB),MR2(IB) 

 1972 DO 150 N=NR1(IB),NR2(IB) 

 1973 H=D(N,M)+SE(N,M) 

 1974 c x-direction 

 1975 IF(IDIR.EQ.1)THEN 

 1976 F1=H/(D(N,M+IS)+SE(N,M+IS)) 

 1977 AH(N,M)=AH(N,M+IS)*F1 

 1978 DO L=1,LBOT 

 1979 AH3(L,N,M)=AH3(L,N,M+IS)*F1 

 1980 ENDDO 

 1981 ENDIF 

 1982 c y-direction 

 1983 IF(IDIR.EQ.2)THEN 

 1984 F2=H/(D(N+IS,M)+SE(N+IS,M)) 

 1985 AH(N,M)=AH(N+IS,M)*F2 

 1986 DO L=1,LBOT 

 1987 AH3(L,N,M)=AH3(L,N+IS,M)*F2 

 1988 ENDDO 
37

 1989 ENDIF 

 1990 150 CONTINUE 

 1991 C CORNER VALUES 

 1992 160 DO 170 M=1,MMAX 

 1993 MP=MIN0(M+1,MMAX) 

 1994 DO 170 N=1,NMAX 

 1995 NP=MIN0(N+1,NMAX) 

 1996 IF(IFIELD(N,M).LT.10)GOTO 170 

 1997 AHC(N,M)=.25*(AH(N,M)+AH(N,MP)+AH(NP,M)+AH(NP,MP)) 

 1998 170 CONTINUE 

 1999 180 RETURN 

 2000 END 

 2001 C 

 2002 C----------------------------------------------------------------------- 

 2003 C 

 2004 SUBROUTINE UHVH 

 2005 C JANUARY 1997 K.W. HESS 

 2006 C PURPOSE - TO COMPUTE EXTERNAL-MODE FLOWRATES AND WATER LEVELS 

 2007 C FROM REVISED EQUATIONS FOR VARIABLE GRID WIDTH (TO 

 2008 C MODEL NARROW RIVER WIDTHS). 

 2009 C VARIABLES - 

 2010 C BX = GRID WIDTH FOR FLOW IN X DIRECTION 

 2011 C BY = GRID WIDTH FOR FLOW IN Y DIRECTION 

 2012 C THETA1 = INTEGRAL OF (1+U/UB)**2 TIMES UE*BX 

 2013 C THETA2 = INTEGRAL OF (1+V/VB)**2 TIMES VE*BY 

 2014 C THETA3 = VERTICAL INTEGRAL OF UB*VB*(1+U/UB)*(1+V/VB) 

 2015 INCLUDE 'COMM20.FOR' 

 2016 BETAH=MAX0(0,MIN0(1,IBETAH)) 

 2017 BETAA=MAX0(0,MIN0(1,IBETAA)) 

 2018 CX1=.25*DTE/DL 

 2019 CX2=.5*AG*DTE/DL 

 2020 CX3=DTE/DL 

 2021 CX4=DTE/DL**2 

 2022 CX5=.5*DTE/DL 

 2023 CX6=.25*AG*DTE/DL 

 2024 CX7=1./CX1 

 2025 CX8=1./CX5 

 2026 CX9=2.*DTE/DL**2 ! additional constant 

 2027 CX10=0.1/RHOW 

 2028 GAMMA=1.0 

 2029 IF(IBOTV.EQ.0)GAMMA=.0 

 2030 IF(IBOTV.EQ.3)GAMMA=.5 

 2031 C 

 2032 C X-DIRECTION SWEEP 

 2033 C 

 2034 DO 220 NC=1,NCOL 

 2035 N=ICOL(1,NC) 

 2036 MA=ICOL(2,NC) 

 2037 MB=ICOL(3,NC) 

 2038 ILFT=ICOL(4,NC) 

 2039 IRGT=ICOL(5,NC) 

 2040 MAM=MA-1 

 2041 NM=MAX0(N-1,1) 

 2042 NP=MIN0(N+1,NMAX) 

 2043 C SWEEP DOWN THE COLUMN 

 2044 DO 200 M=MAM,MB 

 2045 MM=MAX0(M-1,1) 

 2046 MP=MIN0(M+1,MMAX) 

 2047 MPP=MIN0(M+2,MMAX) 

 2048 HS=D(N,M)+BETAH*SE(N,M)+E 

 2049 HP=D(N,MP)+BETAH*SE(N,MP)+E 

 2050 HM=D(N,MM)+BETAH*SE(N,MM)+E 

 2051 HPP=D(N,MPP)+BETAH*SE(N,MPP)+E 

 2052 HB=.5*(HS+HP) 

 2053 AREAP=AREA(N,M) 

 2054 HH=CX2*(HS+HP) 

 2055 C TOTAL STRESS FORMULATION 

 2056 FBAR=.5*(PHI(N,M)+PHI(N,MP)) 

 2057 EDGE=AMIN1(FEDGE(N,M),FEDGE(N,MP)) 

 2058 XDT=DTE*(EDGE*(.5*(TSX(N,M)+TSX(N,MP))-CX10*HB*DPADX-HB* 

 2059 1 GSTARX(N,M))-FBAR*(GAMMA*U(LBOT,N,M)+(1.-GAMMA)*U(LBOT-1,N,M))) 

 2060 C CHANNEL: NO:BETAC=0 YES:BETAC=1 

 2061 BETAC=1-IFIX(BX(N,M)) 

 2062 DTFNM=DTE*(FBAR/HB+BETAC*THETSU(N,M)) 

 2063 C LOWER END BOUNDARY CONDITIONS 

 2064 IF(M.GT.MAM)GOTO 160 

 2065 AREAP=AREA(N,MP) 

 2066 DMP=AREAP*SE(N,MP)-CX1*(BX(N,MP)*UH(N,MP)-BX(N,M)*UH(N,M) 

 2067 1 +2.*(BY(N,MP)*VH(N,MP)-BY(NM,MP)*VH(NM,MP))) 

 2068 C WATER LEVEL CONDITION 

 2069 IF(ILFT.GT.0)GOTO 150 

 2070 DENOM=1./(1.+DTFNM) 

 2071 FA(M)=(UH(N,M)+XDT+HH*SEP(N,M))*DENOM 

 2072 FB(M)=HH*DENOM 

 2073 GOTO 200 

 2074 C FLOWRATE CONDITION 

 2075 150 FA(M)=UHP(N,M) 

 2076 FB(M)=0.0 

 2077 GOTO 200 

 2078 C INTERIOR COMPUTATIONAL GRIDS: MASS RECURSION 

 2079 160 AREAX=AREAP 

 2080 DENOM=1./(AREAX+CX1*BX(N,MM)*FB(MM)) 

 2081 GA(M)=(DMP+CX1*BX(N,MM)*FA(MM))*DENOM 

 2082 GB(M)=CX1*BX(N,M)*DENOM 

 2083 C CHECK FOR UPPER BOUNDARY (M=MB) 

 2084 IF(M.EQ.MB)GOTO 180 

 2085 C START COMPUTING THE MOMENTUM RECURSION ARRAYS 

 2086 VB=(VH(N,M)+VH(N,MP)+VH(NM,M)+VH(NM,MP))/(FLOAT(NFLUX(N,M)+ 

 2087 1 NFLUX(N,MP)+NFLUX(NM,M)+NFLUX(NM,MP))+E) 

 2088 FCOR=EDGE*(FCOR0+DFDM*FLOAT(M-MCOR)+DFDN*FLOAT(N-NCOR)) 

 2089 AREAP=AREA(N,MP) 

 2090 DMP=AREAP*SE(N,MP)-CX1*(BX(N,MP)*UH(N,MP)-BX(N,M)*UH(N,M) 

 2091 1 +2.*(BY(N,MP)*VH(N,MP)-BY(NM,MP)*VH(NM,MP))) 

 2092 BXI=1.0/BX(N,M) 

 2093 BP=CX9*(1.+BX(N,MP)*BXI)*AH(N,MP) 

 2094 BM=CX9*(1.+BX(N,MM)*BXI)*AH(N,M) 

 2095 C NON-LINEAR TERMS 

 2096 AUV=BETAA*CX3*(THETA3(N,M)-THETA3(NM,M)) 

 2097 CU=SIGN(1.0,UH(N,M)) 

 2098 FN1=BETAA*CX5*(1.+CU)*BXI*THETA1(N,MM) 

 2099 FN2=BETAA*CX5*((1.+CU)-(1.-CU))*BXI*THETA1(N,M) 

 2100 FN3=BETAA*CX5*(1.-CU)*BXI*THETA1(N,MP) 

 2101 C LATERAL VISCOSITY TERM 

 2102 AHDUYY=CX4*(AHC(N,M)*(UE(NP,M)-UE(N,M)+VE(N,MP)-VE(N,M))- 

 2103 1 AHC(NM,M)*(UE(N,M)-UE(NM,M)+VE(NM,MP)-VE(NM,M)))*(1.-BETAC) 

 2104 C SET RECURSION ARRAY HERE 

 2105 F1=-BM/(HS+HM)-FN1 

 2106 F2=1.+DTFNM+(BP+BM)/(HS+HP)+FN2 

 2107 F3=-BP/(HP+HPP)+FN3 

 2108 F4=UH(N,M)+XDT+AHDUYY+FCOR*VB-AUV 

 2109 BXIP=F3/BX(N,MP) 

 2110 DENOM=1./(GB(M)*(HH+F1*FB(MM))+F2+BX(N,M)*BXIP) 

 2111 FA(M)=(F4-F1*FA(MM)+GA(M)*(F1*FB(MM)+HH)-DMP*CX7*BXIP)*DENOM 

 2112 FB(M)=(HH-AREAP*CX7*BXIP)*DENOM 

 2113 GOTO 200 

 2114 C UPPER END BOUNDARY CONDITIONS 

 2115 180 IF(IRGT.GT.0)GOTO 190 

 2116 DENOM=1./(1.+HH*GB(M)+DTFNM) 

 2117 FA(M)=(UH(N,M)+XDT+HH*GA(M))*DENOM 

 2118 FB(M)=HH*DENOM 

 2119 F1=UH(N,M)+XDT+HH*GA(M) 

 2120 GOTO 200 

 2121 190 FA(M)=UHP(N,M) 

 2122 FB(M)=0.0 

 2123 200 CONTINUE 

 2124 C LOOP BACK DOWN THE COLUMN, CALCULATING FLOWRATE & WATER LEVEL 

 2125 DO 210 MM=MA,MB 

 2126 M=MA+MB-MM 

 2127 UHP(N,M)=FA(M)-FB(M)*SEP(N,M + 1) 

 2128 SEP(N,M)=GA(M)-GB(M)*UHP(N,M) 

 2129 C MAKE SURE DEPTH IS POSITIVE 

 2130 IF(SEP(N,M)+D(N,M).GT.0.0)GOTO 210 

 2131 NEGS=NEGS+1 

 2132 SEP(N,M)=0.10-D(N,M) 

 2133 210 CONTINUE 

 2134 UHP(N,MAM)=FA(MAM)-FB(MAM)*SEP(N,MA) 

 2135 220 CONTINUE 

 2136 C 

 2137 C Y-DIRECTION SWEEP 

 2138 C 

 2139 280 DO 370 NR=1,NROW 

 2140 M=IROW(1,NR) 

 2141 NA=IROW(2,NR) 

 2142 NB=IROW(3,NR) 

 2143 ILFT=IROW(4,NR) 

 2144 IRGT=IROW(5,NR) 

 2145 NAM=NA-1 

 2146 MM=MAX0(M-1,1) 

 2147 MP=MIN0(M+1,MMAX) 

 2148 C SWEEP ACROSS ROWS 

 2149 DO 350 N=NAM,NB 

 2150 NM=MAX0(N-1,1) 

 2151 NP=MIN0(N+1,NMAX) 

 2152 NPP=MIN0(N+2,NMAX) 

 2153 HS=D(N,M)+BETAH*SE(N,M)+E 

 2154 HP=D(NP,M)+BETAH*SE(NP,M)+E 

 2155 HM=D(NM,M)+BETAH*SE(NM,M)+E 

 2156 HPP=D(NPP,M)+BETAH*SE(NPP,M)+E 

 2157 HB=.5*(HS+HP) 

 2158 AREAP=AREA(N,M) 

 2159 HH=CX6*(HS+HP) 

 2160 C EXTERNAL FORCES 

 2161 FBAR=.5*(PHI(N,M)+PHI(NP,M)) 

 2162 EDGE=AMIN1(FEDGE(N,M),FEDGE(NP,M)) 

 2163 YDT=DTE*(EDGE*(.5*(TSY(N,M)+TSY(NP,M))-CX10*HB*DPADY-HB* 

 2164 1 GSTARY(N,M))-FBAR*(GAMMA*V(LBOT,N,M)+(1.-GAMMA)*V(LBOT-1,N,M))) 

 2165 C CHANNEL: NO:BETAC=0 YES:BETAC=1 

 2166 BETAC=1-IFIX(BY(N,M)) 

 2167 DTFNM=DTE*(FBAR/HB+BETAC*THETSV(N,M)) 

 2168 C CHECK FOR LOWER END BOUNDARY CONDITIONS 

 2169 IF(N.GT.NAM)GOTO 310 

 2170 AREAP=AREA(NP,M) 

 2171 DNP=AREAP*SEP(NP,M)-CX1*(BX(NP,M)*(UHP(NP,M)+UH(NP,M)) 

 2172 1 -BX(NP,MM)*(UHP(NP,MM)+UH(NP,MM))) 

 2173 C WATER LEVEL CONDITION 

 2174 IF(ILFT.GT.0)GOTO 300 

 2175 DENOM=1./(1.+DTFNM) 

 2176 FA(N)=(VH(N,M)+YDT+HH*(SEPP(N,M)-SE(NP,M)+SE(N,M)))*DENOM 

 2177 FB(N)=HH*DENOM 

 2178 GOTO 350 

 2179 C FLOWRATE CONDITION 

 2180 300 FA(N)=VHP(N,M) 

 2181 FB(N)=0.0 

 2182 GOTO 350 

 2183 C INTERIOR COMPUTATIONAL GRIDS: MASS RECURSION 

 2184 310 AREAX=AREAP 

 2185 DENOM=1./(AREAX+CX5*BY(NM,M)*FB(NM)) 

 2186 GA(N)=(DNP+CX5*BY(NM,M)*FA(NM))*DENOM 

 2187 GB(N)=CX5*BY(N,M)*DENOM 

 2188 C CHECK FOR UPPER END (N=NB) 

 2189 IF(N.EQ.NB) GOTO 330 

 2190 C START COMPUTING THE MOMENTUM RECURSION ARRAYS 

 2191 UB=(UH(N,M)+UH(NP,M)+UH(N,MM)+UH(NP,MM))/(FLOAT(MFLUX(N,M)+ 

 2192 1 MFLUX(NP,M)+MFLUX(N,MM)+MFLUX(NP,MM))+E) 

 2193 FCOR=EDGE*(FCOR0+DFDM*FLOAT(M-MCOR)+DFDN*FLOAT(N-NCOR)) 

 2194 AREAP=AREA(NP,M) 

 2195 DNP=AREAP*SEP(NP,M)-CX1*(BX(NP,M)*(UHP(NP,M)+UH(NP,M)) 

 2196 1 -BX(NP,MM)*(UHP(NP,MM)+UH(NP,MM))) 

 2197 BYI=1.0/BY(N,M) 

 2198 BP=CX9*(1.+BY(NP,M)*BYI)*AH(NP,M) 

 2199 BM=CX9*(1.+BY(NM,M)*BYI)*AH(N,M) 

 2200 C NON-LINEAR TERMS 

 2201 AUV=BETAA*CX3*(THETA3(N,M)-THETA3(N,MM)) 

 2202 CV=SIGN(1.0,VH(N,M)) 

 2203 FN1=BETAA*CX5*(1.+CV)*BYI*THETA2(NM,M) 

 2204 FN2=BETAA*CX5*((1.+CV)-(1.-CV))*BYI*THETA2(N,M) 

 2205 FN3=BETAA*CX5*(1.-CV)*BYI*THETA2(NP,M) 

 2206 C LATERAL VISCOSITY TERM 

 2207 AHDVXX=CX4*(AHC(N,M)*(UE(NP,M)-UE(N,M)+VE(N,MP)-VE(N,M))- 

 2208 1 AHC(N,MM)*(UE(NP,MM)-UE(N,MM)+VE(N,M)-VE(N,MM)))*(1.-BETAC) 

 2209 C SET RECURSION ARRAY HERE 

 2210 F1=-BM/(HS+HM)-FN1 

 2211 F2=1.+DTFNM+(BP+BM)/(HS+HP)+FN2 

 2212 F3=-BP/(HP+HPP+E)+FN3 

 2213 F4=VH(N,M)+YDT+AHDVXX-FCOR*UB-AUV-HH*(SE(NP,M)-SE(N,M)) 

 2214 BYIP=F3/BY(NP,M) 

 2215 DENOM=1./(GB(N)*(HH+F1*FB(NM))+F2+BYIP*BY(N,M)) 

 2216 FA(N)=(F4-F1*FA(NM)+GA(N)*(HH+F1*FB(NM))-DNP*CX8*BYIP)*DENOM 

 2217 FB(N)=(HH-CX8*AREAP*BYIP)*DENOM 

 2218 GOTO 350 

 2219 C UPPER END BOUNDARY CONDITIONS 

 2220 330 IF(IRGT.GT.0)GOTO 340 

 2221 DENOM=1./(1.+HH*GB(N)+DTFNM) 

 2222 FA(N)=(VH(N,M)+YDT+HH*(GA(N)-SE(NP,M)+SE(N,M)))*DENOM 

 2223 FB(N)=HH*DENOM 

 2224 GOTO 350 

 2225 340 FA(N)=VHP(N,M) 

 2226 FB(N)=0.0 

 2227 350 CONTINUE 

 2228 C LOOP BACK DOWN THE ROW, CALCULATING FLOWRATE AND WATER LEVEL 

 2229 DO 360 NN=NA,NB 

 2230 N=NA+NB-NN 

 2231 VHP(N,M)=FA(N)-FB(N)*SEPP(N + 1,M) 

 2232 SEPP(N,M)=GA(N)-GB(N)*VHP(N,M) 

 2233 C MAKE SURE DEPTHS ARE POSITIVE 

 2234 IF(SEPP(N,M)+D(N,M).GT.0.0)GOTO 360 

 2235 NEGS=NEGS+1 

 2236 SEPP(N,M)=0.10-D(N,M) 

 2237 360 CONTINUE 

 2238 VHP(NAM,M)=FA(NAM)-FB(NAM)*SEPP(NA,M) 

 2239 370 CONTINUE 

 2240 C 
38

 2241 C UPDATE AND SAVE VARIABLES 

 2242 F1=2. 

 2243 F2=1. 

 2244 IF(NSTE.EQ.ISPLIT)THEN 

 2245 F1=1. 

 2246 F2=.5/FLOAT(ISPLIT) 

 2247 END IF 

 2248 DO 390 N=1,NMAX 

 2249 DO 390 M=1,MMAX 

 2250 UH(N,M)=UHP(N,M) 

 2251 VH(N,M)=VHP(N,M) 

 2252 SE(N,M)=SEPP(N,M) 

 2253 UHOLD(N,M)=F2*(UHOLD(N,M)+F1*UH(N,M)) 

 2254 390 VHOLD(N,M)=F2*(VHOLD(N,M)+F1*VH(N,M)) 

 2255 C COMPUTE EXTERNAL-MODE VELOCITY 

 2256 DO 400 N=1,NMAX 

 2257 NP=MIN0(N+1,NMAX) 

 2258 DO 400 M=1,MMAX 

 2259 MP=MIN0(M+1,MMAX) 

 2260 UE(N,M)=UH(N,M)*(1.+FLOAT(MFLUX(N,M)))/ 

 2261 1 ((D(N,M)+D(N,MP)+BETAH*(SE(N,M)+SE(N,MP))+E)) 

 2262 VE(N,M)=VH(N,M)*(1.+FLOAT(NFLUX(N,M)))/ 

 2263 1 ((D(N,M)+D(NP,M)+BETAH*(SE(N,M)+SE(NP,M))+E)) 

 2264 400 CONTINUE 

 2265 C 

 2266 RETURN 

 2267 END 

 2268 C====================================================================== 

 2269 C FILE INTRNL.FOR 

 2270 C----------------------------------------------------------------------- 

 2271 C 

 2272 SUBROUTINE INTRNL 

 2273 C MAY 1988 K. W. HESS TDL 

 2274 C PURPOSE - TO COMPUTE THE INTERNAL MODE VARIABLES WITH VARIABLE 

 2275 C WIDTH. THESE ARE THE VERTICAL VELOCITIES, EDDY VISCOS 

 2276 C AND HORIZONTAL VELOCITY DEPARTURES FROM THE VERTICAL 

 2277 C MEAN. 

 2278 C VARIABLES - 

 2279 C ISKIP = INDEX FOR SKIPPING THE UPDATE OF THE EDDY VISCO 

 2280 C 

 2281 INCLUDE 'COMM20.FOR' 

 2282 C CHECK FOR SKIPPING ALL INTERNAL-MODE CALCS 

 2283 IF(INTER.EQ.0)GOTO 100 

 2284 C GET INTERNAL-MODE BOUNDARY CONDITIONS FOR NON-WATERFALLS 

 2285 CALL BNDRY2 

 2286 C UPDATE TURBULENT MOMENTUM TRANSFER COEFFICIENTS. 

 2287 IF(IVISC.GT.0.AND.(NSTI.LE.IHR.OR.MOD(NSTI,IVISC).EQ.0)) 

 2288 1 CALL VERVIS 

 2289 C GET INTERNAL-MODE VELOCITIES 

 2290 CALL UPVP 

 2291 C GET VERTICAL VELOCITY 

 2292 CALL WVERT 

 2293 C GET UPDATED THETA'S 

 2294 100 CONTINUE 

 2295 RETURN 

 2296 END 

 2297 C 

 2298 C----------------------------------------------------------------------- 

 2299 C 

 2300 SUBROUTINE BNDRY2 

 2301 C OCTOBER 1984 K. W. HESS MEAD VAX11/750 

 2302 C PURPOSE - TO SET THE RIVER'S INTERNAL-MODE VELOCITY BOUNDARY 

 2303 C CONDITIONS FOR NON-FALLS CONDITION. 

 2304 C VARIABLES - 

 2305 C QRIV = RIVER FLOWRATE (M**3/S) 

 2306 C JTPR() = RIVERINE CONDITION: 1=FLUME, 2=WATER FALLS 

 2307 INCLUDE 'COMM20.FOR' 

 2308 C RIVER FLOW BOUNDARIES 

 2309 IF(NUMRIV.LE.0)GOTO 130 

 2310 C LOOP THRU THE RIVERS 

 2311 DO 120 NR=1,NUMRIV 

 2312 IF(JTPR(NR).EQ.2)GOTO 120 

 2313 C FLUME CONDITIONS. SET DIRECTION AND SENSE 

 2314 IDIR=IABS(ITPR(NR)) 

 2315 c IS=0 

 2316 c IF(ITPR(NR).LT.0)IS=-1 

 2317 c F1=1. 

 2318 c IF(ITPR(NR).LE.0)F1=-1. 

 2319 F1=ISIGN(1,ITPR(NR)) 

 2320 IS=(1-ISIGN(1,ITPR(NR)))/2 

 2321 C LOOP THRU CELLS AT BOUNDARY 

 2322 UTOP=0. 

 2323 DO 110 M=MR1(NR),MR2(NR) 

 2324 DO 110 N=NR1(NR),NR2(NR) 

 2325 C SET NEW VELOCITIES 

 2326 F2=F1*UTOP 

 2327 IBARR=0 

 2328 IF(IDIR.EQ.1)IBARR=MOD(IFIELD(N,M+IS),10) 

 2329 IF(IDIR.EQ.2)IBARR=MOD(IFIELD(N+IS,M),10) 

 2330 IF(IDIR.EQ.1.AND.(IBARR.EQ.1.OR.IBARR.EQ.3))F2=0.0 

 2331 IF(IDIR.EQ.2.AND.IBARR.GE.2)F2=0.0 

 2332 F3=PI*DQ 

 2333 DO 100 L=1,LBOT 

 2334 FVE=COS(F3*FLOAT(L-1)) 

 2335 IF(IDIR.EQ.1)U(L,N,M+IS)=F2*FVE 

 2336 IF(IDIR.EQ.2)V(L,N+IS,M)=F2*FVE 

 2337 100 CONTINUE 

 2338 110 CONTINUE 

 2339 120 CONTINUE 

 2340 130 RETURN 

 2341 END 

 2342 C 

 2343 C------------------------------------------------------------------ 

 2344 C 

 2345 FUNCTION FRHO(SAL,TMP) 

 2346 C JUNE 1996 K. W. HESS CEOB SGI 

 2347 C PURPOSE - TO GENERATE THE ADDED WATER DENSITY DUE TO SALINITY 

 2348 C (S) AND TEMPERATURE (T) DEG. C. THAT IS, 

 2349 C RHO = RHOW + 1000*FRHO(S,T) kg/m**3 

 2350 C MAMAEV FORMULATION 

 2351 SS=AMAX1(SAL,0.0) 

 2352 TT=AMAX1(TMP,0.0) 

 2353 FRHO= 7.E-5+SS*(8.02E-4-2.0E-6*TT)-TT*(3.5E-6+4.69E-6*TT) 

 2354 RETURN 

 2355 END 

 2356 C 

 2357 C------------------------------------------------------------------ 

 2358 C 

 2359 FUNCTION FRHO2(S1,T1) 

 2360 C UNESCO FORMULATION 

 2361 DATA RHO0/1000./ 

 2362 TR=AMAX1(0.0,T1) 

 2363 SR=AMAX1(0.0,S1) 

 2364 RHOR = 999.842594 + 6.793952E-2*TR 

 2365 $ - 9.095290E-3*TR**2 + 1.001685E-4*TR**3 

 2366 $ - 1.120083E-6*TR**4 + 6.536332E-9*TR**5 

 2367 RHOR = RHOR + (0.824493 - 4.0899E-3*TR 

 2368 $ + 7.6438E-5*TR**2 - 8.2467E-7*TR**3 

 2369 $ + 5.3875E-9*TR**4) * SR 

 2370 $ + (-5.72466E-3 + 1.0227E-4*TR 

 2371 $ - 1.6546E-6*TR**2) * SR**1.5 

 2372 $ + 4.8314E-4 * SR**2 

 2373 FRHO=(RHOR-RHO0)*1.E-3 

 2374 RETURN 

 2375 END 

 2376 C 

 2377 C------------------------------------------------------------------ 

 2378 C 

 2379 SUBROUTINE GRADP(N,M,INTGRL) 

 2380 C PURPOSE - TO COMPUTE HORIZONTAL GRADIENTS DUE TO DENSITY. 

 2381 C NOTE: RHO = RHOW + FRHO(S,T) 

 2382 C VARIABLES - 

 2383 C INTGRL = INDEX TO UPDATE INTEGRATED PRESSURE:1=YES 

 2384 INCLUDE 'COMM20.FOR' 

 2385 C SET INITIAL GRADIENTS 

 2386 DO 100 L=1,LBOT 

 2387 GRX(L)=0.0 

 2388 100 GRY(L)=0.0 

 2389 IF(ICOUPL.LE.1.OR.IBETAP.EQ.0.OR.RAMPG.EQ.0.)RETURN 

 2390 C SET CONSTANTS 

 2391 MP=MIN0(M+1,MMAX) 

 2392 NP=MIN0(N+1,NMAX) 

 2393 CO1=RAMPG*AG/DL 

 2394 CO2=CO1*DQ 

 2395 C SET BATHYMETRY VALUES 

 2396 H1=(D(N,M)+SE(N,M)) 

 2397 H2=(D(N,MP)+SE(N,MP)) 

 2398 DELSX=SE(N,MP)-SE(N,M) 

 2399 DELHX=H2-H1 

 2400 H3=(D(NP,M)+SE(NP,M)) 

 2401 DELSY=SE(NP,M)-SE(N,M) 

 2402 DELHY=H3-H1 

 2403 C INITIALIZE PRESSURE AND DENSITY TERMS 

 2404 SX=0. 

 2405 SXP=0. 

 2406 SY=0. 

 2407 SYP=0. 

 2408 PX=0. 

 2409 PY=0. 

 2410 C LOOP OVER DEPTHS 

 2411 IF(MFLUX(N,M).EQ.0.OR.H2.LE.0.0)GOTO 120 

 2412 C X-DIRECTION GRADIENTS 

 2413 DO 110 L=1,LBOT 

 2414 Q=FLOAT(1-L)*DQ 

 2415 SAVG=.5*(S(L,N,M)+S(L,N,MP)) 

 2416 TAVG=.5*(T(L,N,M)+T(L,N,MP)) 

 2417 GRX(L)=(DELSX+DELHX*Q)*CO1*FRHO(SAVG,TAVG) 

 2418 IF(L.EQ.1)GOTO 105 

 2419 SAVGMP=.5*(S(L,N,MP)+S(L-1,N,MP)) 

 2420 TAVGMP=.5*(T(L,N,MP)+T(L-1,N,MP)) 

 2421 SXP=SXP+CO2*FRHO(SAVGMP,TAVGMP) 

 2422 SAVGM=.5*(S(L,N,M)+S(L-1,N,M)) 

 2423 TAVGM=.5*(T(L,N,M)+T(L-1,N,M)) 

 2424 SX=SX+CO2*FRHO(SAVGM,TAVGM) 

 2425 GRX(L)=GRX(L)+(SXP*H2-SX*H1) 

 2426 105 PX=PX+CI(L)*GRX(L) 

 2427 110 CONTINUE 

 2428 C Y-DIRECTION 

 2429 120 IF(NFLUX(N,M).EQ.0.OR.H3.LE.0.0)GOTO 140 

 2430 DO 130 L=1,LBOT 

 2431 Q=FLOAT(1-L)*DQ 

 2432 SAVG=.5*(S(L,N,M)+S(L,NP,M)) 

 2433 TAVG=.5*(T(L,N,M)+T(L,NP,M)) 

 2434 GRY(L)=(DELSY+DELHY*Q)*CO1*FRHO(SAVG,TAVG) 

 2435 c IF(L.EQ.1)GOTO 130 

 2436 IF(L.EQ.1)GOTO 125 

 2437 SAVGNP=.5*(S(L,NP,M)+S(L-1,NP,M)) 

 2438 TAVGNP=.5*(T(L,NP,M)+T(L-1,NP,M)) 

 2439 SYP=SYP+CO2*FRHO(SAVGNP,TAVGNP) 

 2440 SAVGN=.5*(S(L,N,M)+S(L-1,N,M)) 

 2441 TAVGN=.5*(T(L,N,M)+T(L-1,N,M)) 

 2442 SY=SY+CO2*FRHO(SAVGN,TAVGN) 

 2443 GRY(L)=GRY(L)+(SYP*H3-SY*H1) 

 2444 125 PY=PY+CI(L)*GRY(L) 

 2445 130 CONTINUE 

 2446 140 CONTINUE 

 2447 C INTEGRATED PRESSURE 

 2448 IF(INTGRL.NE.1)GOTO 150 

 2449 GSTARX(N,M)=PX 

 2450 GSTARY(N,M)=PY 

 2451 150 RETURN 

 2452 END 

 2453 C 

 2454 C----------------------------------------------------------------------- 

 2455 C 

 2456 SUBROUTINE THETAS 

 2457 C JAN 1997 K.W.HESS 

 2458 C PURPOSE - TO COMPUTE THE THETA FUNCTIONS. 

 2459 C VARIABLES - 

 2460 C THETA1(,) = BX*UE*INTEGRAL OVER DEPTH OF:(1 + U/UE)**2 

 2461 C THETA2(,) = BY*VE*INTEGRAL OVER DEPTH OF:(1 + V/VE)**2 

 2462 C THETA3(,) = UE*VE*INTEGRAL OVER DEPTH OF:(1+U/UE)*(1+V/VE) 

 2463 C THETSU(,) = INTEGRAL OVER DEPTH OF (1 + U/UE)*ABS(1 + U/UE) 

 2464 C TIMES CDRGWS*H/BX 

 2465 C THETSV(,) = INTEGRAL OVER DEPTH OF (1 + V/VE)*ABS(1 + V/VE) 

 2466 C TIMES CDRGWS*H/BY 

 2467 INCLUDE 'COMM20.FOR' 

 2468 MMAXM=MMAX-1 

 2469 NMAXM=NMAX-1 

 2470 DO 250 M=1,MMAXM 

 2471 DO 250 N=1,NMAXM 

 2472 IF(IFIELD(N,M).LT.10)GOTO 250 

 2473 c EXTERNAL-MODE ONLY 

 2474 IF(INTER.NE.0)GOTO 150 

 2475 TH1=1.0 

 2476 TH2=1.0 

 2477 TH3=.25*(UE(N,M)+UE(N+1,M))*(VE(N,M)+VE(N,M+1)) 

 2478 TS1=1.0 

 2479 TS2=1.0 

 2480 GOTO 210 

 2481 C INTERNAL MODE. GET RECIPROCAL OF UE, VE 

 2482 150 UBI=1./SIGN(AMAX1(ABS(UE(N,M)),0.0001),UE(N,M)) 

 2483 VBI=1./SIGN(AMAX1(ABS(VE(N,M)),0.0001),VE(N,M)) 

 2484 C SUM OVER DEPTH 

 2485 TH1=0.0 

 2486 TH2=0.0 

 2487 TH3=0.0 

 2488 TS1=0.0 

 2489 TS2=0.0 

 2490 DO 200 L=1,LBOT 

 2491 IF(IBETAA.LE.0)GOTO 180 

 2492 TH1=TH1+CI(L)*(1.+U(L,N,M)*UBI)**2 
39

 2493 TH2=TH2+CI(L)*(1.+V(L,N,M)*VBI)**2 

 2494 TH3=TH3+CI(L)*.25*(UE(N,M)+U(L,N,M)+UE(N+1,M)+U(L,N+1,M))* 

 2495 1 (VE(N,M)+V(L,N,M)+VE(N,M+1)+V(L,N,M+1)) 

 2496 180 IF(BX(N,M).LT.1.0)TS1=TS1+CI(L)*(1.+U(L,N,M)*UBI)*ABS(1.+ 

 2497 1 U(L,N,M)*UBI) 

 2498 IF(BY(N,M).LT.1.0)TS2=TS2+CI(L)*(1.+V(L,N,M)*VBI)*ABS(1.+ 

 2499 1 V(L,N,M)*VBI) 

 2500 200 CONTINUE 

 2501 C CHECK MAGNITUDES OF NON-LINEAR TERM INTEGRALS 

 2502 210 IF(IBETAA.LE.0)GOTO 230 

 2503 THETA1(N,M)=.5*(THETA1(N,M)+AMIN1(10.0,TH1)*UE(N,M)*BX(N,M)) 

 2504 THETA2(N,M)=.5*(THETA2(N,M)+AMIN1(10.0,TH2)*VE(N,M)*BY(N,M)) 

 2505 TH3=SIGN(AMIN1(ABS(TH3),10.0),TH3) 

 2506 IF(MOD(IFIELD(N,M),10).GT.0.OR.IFIELD(N+1,M).LT.10.OR. 

 2507 1 IFIELD(N,M+1).LT.10.OR.IFIELD(N+1,M+1).LT.10)TH3=0.0 

 2508 THETA3(N,M)=.5*(THETA3(N,M)+TH3) 

 2509 C SIDE FRICTION TERMS 

 2510 230 THETSU(N,M)=CDRGWS*TS1*ABS(UE(N,M))/(DL*BX(N,M)) 

 2511 THETSV(N,M)=CDRGWS*TS2*ABS(VE(N,M))/(DL*BY(N,M)) 

 2512 250 CONTINUE 

 2513 RETURN 

 2514 END 

 2515 C 

 2516 c-------------------------------------------------------------- 

 2517 C 

 2518 SUBROUTINE GETCJ(CJ,CI,LBOT,LSIZE,IBOTV) 

 2519 C FACTOR TO REDISTRIBUTE ANY NON-ZERO INTERNAL-MODEL VELOCITY, 

 2520 C MAINTAINING SAME BOTTOM VELOCITY IF IBOTV=0. 

 2521 DIMENSION CJ(LSIZE),CI(LSIZE) 

 2522 SUM=0. 

 2523 DO L=1,LBOT 

 2524 CJ(L)=1. 

 2525 IF(IBOTV.EQ.0)CJ(L)=MAX0(MIN0(LBOT-L,2),0) 

 2526 SUM=SUM+CI(L)*CJ(L) 

 2527 ENDDO 

 2528 DO L=1,LBOT 

 2529 CJ(L)=CJ(L)/SUM 

 2530 ENDDO 

 2531 RETURN 

 2532 END 

 2533 C 

 2534 C----------------------------------------------------------------------- 

 2535 C 

 2536 SUBROUTINE UPVP 

 2537 

 2538 C MARCH 1996 K. W. HESS CEOB 

 2539 C PURPOSE - TO COMPUTE THE INTERNAL MODE VARIABLES WITH VARIABLE 

 2540 C WIDTH. THESE ARE THE VERTICAL VELOCITIES, EDDY VISCOS 

 2541 C AND HORIZONTAL VELOCITY DEPARTURES FROM THE VERTICAL 

 2542 C (SEE MECCA PROGRAM DOCUMENTATION, PART B). 

 2543 C INCLUDES NON-LINEAR TERMS W/O IF STATEMENTS AND 

 2544 C HAS 3-D HORIZONTAL VISCOSITY. 

 2545 C VARIABLES - 

 2546 C IBOTV = BOTTOM B.C. INDEX: 

 2547 C 0 : U=0 

 2548 C 1 : AvDU/DZ = TBX first order DU/DZ 

 2549 C 2 : AvDU/DZ = TBX second order DU/DZ 

 2550 C 3 : AvDU/DZ = TBX log-layer, mid-level 

 2551 C ITOPV = ORDER OF TOP B.C. DERIVATIVE 

 2552 C 1 : FIRST ORDER DU/DZ 

 2553 C 2 : SECOND. 

 2554 C 3 : FIRST-ORDER TOTAL 

 2555 C 

 2556 INCLUDE 'COMM20.FOR' 

 2557 DIMENSION UP(LSIZE),UPM(LSIZE,NSIZE),UPMM(LSIZE,NSIZE),VP(LSIZE), 

 2558 2 VPM(LSIZE,NSIZE),VPMM(LSIZE,NSIZE),FBC(LSIZE),CJ(LSIZE) 

 2559 CALL GETCJ(CJ,CI,LBOT,LSIZE,IBOTV) 

 2560 C NONLINEAR TERMS: INCLUDE IF IBETAA=1 

 2561 FNONL0=0. 

 2562 IF(IBETAA.NE.0)FNONL0=1. 

 2563 C NONLINEAR TERMS:FOR NONL, 1=NO, 2=YES 

 2564 BETAH=MAX0(0,MIN0(1,IBETAH)) 

 2565 KOCN=10*KOCNBC 

 2566 KRIV=10*(KOCNBC+1) 

 2567 LAYRM=LAYRS-1 

 2568 DIFF=0.0 

 2569 C 

 2570 B1=DTI/(8.*DQ) 

 2571 B2=DTI/(2.*DQ**2) 

 2572 B3=DTI/(2.*DL**2) 

 2573 B4=DTI/DL**2 

 2574 B5=DTI/(2.*DL) 

 2575 B6=DTI/DL 

 2576 B7=DTI/(16.*DL) 

 2577 B8=DTI/(4.*DL) 

 2578 B9=2./3. 

 2579 B10=4./3. 

 2580 FSPLIT=ISPLIT 

 2581 C 

 2582 DO 90 L=1,LBOT 

 2583 90 FBC(L)=0.0 

 2584 IF(ITOPV.EQ.2)FBC(2)=0.33333 

 2585 C 

 2586 C BEGIN LOOP THRU THE MESH 

 2587 DO 550 M=1,MMAX 

 2588 C STORE THE PRESENT VELOCITIES 

 2589 DO 120 N=1,NMAX 

 2590 DO 120 L=1,LBOT 

 2591 IF(M.GT.1)GOTO 100 

 2592 UPMM(L,N)=0.0 

 2593 VPMM(L,N)=0.0 

 2594 GOTO 110 

 2595 100 UPMM(L,N)=UPM(L,N) 

 2596 IF(M.EQ.1)UPMM(L,N)=2.*UPM(L,M)-U(L,N,M+1) 

 2597 VPMM(L,N)=VPM(L,N) 

 2598 110 UPM(L,N)=U(L,N,M) 

 2599 VPM(L,N)=V(L,N,M) 

 2600 IF(N.EQ.1)VPM(L,M)=2.*V(L,N,m)-V(L,N+1,M) 

 2601 120 CONTINUE 

 2602 C DEFINE THE COLUMN LIMITS 

 2603 NA=NAB(M)/1000 

 2604 NB=NAB(M)-1000*NA 

 2605 IF(NA.GT.NB)GOTO 550 

 2606 DO 545 N=NA,NB 

 2607 II=IFIELD(N,M) 

 2608 IF(II.LT.10)GOTO 540 

 2609 IBARR=MOD(II,10) 

 2610 IF(IBARR.EQ.3)GOTO 540 

 2611 C GET THE INTERNAL PRESSURE GRADIENT 

 2612 CALL GRADP(N,M,1) 

 2613 MM=MAX0(M-1,1) 

 2614 MP=MIN0(M+1,MMAX) 

 2615 NM=MAX0(N-1,1) 

 2616 NP=MIN0(N+1,NMAX) 

 2617 C 

 2618 C X-DIRECTION HORIZONTAL VELOCITY DEPARTURE 

 2619 C 

 2620 IF(IBARR.EQ.1.OR.M.EQ.MMAX)GOTO 330 

 2621 IF(IFIELD(N,M).EQ.KOCN.AND.IFIELD(N,MP).EQ.KOCN)GOTO 330 

 2622 C CHECK FOR INCLUSION OF NON-LINEAR TERMS:NLT(1=NO;2=YES) 

 2623 EDGE=AMIN1(FEDGE(N,M),FEDGE(N,MP)) 

 2624 FNONL=FNONL0 

 2625 IF(EDGE.LT.0.55)FNONL=0. 

 2626 C CHECK FOR CHANNEL:NO=0, YES=1. 

 2627 BETAC=1-IFIX(BX(N,M)) 

 2628 C DEPTH-INDEPENDENT VARIABLES 

 2629 HS=D(N,M)+BETAH*SE(N,M) 

 2630 HP=D(N,MP)+BETAH*SE(N,MP) 

 2631 HPP=D(N,MP+1)+BETAH*SE(N,MP+1) 

 2632 HB=.5*(HS+HP) 

 2633 HI=1./(HB+E) 

 2634 HISQ=B2*HI**2 

 2635 C TOTAL EXTERNAL RETARDING FORCES PLUS SIDE STRESS 

 2636 CFS=DTI*BETAC*CDRGWS/(DL*BX(N,M)) 

 2637 XDT=DTI*((TBX(N,M)-.5*TSX(N,M)-.5*TSX(N,MP))*HI+EDGE*GSTARX(N,M) 

 2638 1 + THETSU(N,M)*UE(N,M)) 

 2639 FCOR=EDGE*FSPLIT*(FCOR0+DFDM*FLOAT(M-MCOR)+DFDN*FLOAT(N-NCOR)) 

 2640 DELH=.25*(SEPP(N,M)+SEPP(N,MP)-SOLD(N,M)-SOLD(N,MP))*HI 

 2641 RAP=B3*HI/BX(N,M)*(BX(N,M)+BX(N,MP)) 

 2642 RAM=B3*HI/BX(N,M)*(BX(N,M)+BX(N,MM)) 

 2643 RBP=B4*HI 

 2644 RBM=B4*HI 

 2645 FAVG=1./(E+FLOAT(NFLUX(N,M)+NFLUX(NM,M)+NFLUX(N,MP)+NFLUX(NM,MP))) 

 2646 C NON-LINEAR TERMS 

 2647 CU=SIGN(1.0,UH(N,M)) 

 2648 IF(FNONL.EQ.0.)THEN 

 2649 ANA=0. 

 2650 ELSE 

 2651 F1=B7*HI/BX(N,M) 

 2652 HBXM=F1*BX(N,MM)*(HS+D(N,MM)+BETAH*SE(N,MM)) 

 2653 HBX= F1*BX(N,M)*(HS+HP) 

 2654 HBXP=F1*BX(N,MP)*(HP+HPP) 

 2655 HCP=B8*HI*(HS+HP+D(NP,M)+D(NP,MP)+BETAH*(SE(NP,M)+SE(NP,MP))) 

 2656 HCM=B8*HI*(HS+HP+D(NM,M)+D(NM,MP)+BETAH*(SE(NM,M)+SE(NM,MP))) 

 2657 ANA=FNONL*(B5*HI/BX(N,M)*((1.-CU)*(THETA1(N,MP)*UH(N,MP) 

 2658 1 -THETA1(N,M)*UH(N,M))+(1.+CU)*(THETA1(N,M)*UH(N,M) 

 2659 2 -THETA1(N,MM)*UH(N,MM)))+B6*HI*(THETA3(N,M)-THETA3(NM,M))) 

 2660 END IF 

 2661 C APPLY TOP BOUNDARY CONDITIONS 

 2662 IF(ITOPV.EQ.1)THEN 

 2663 FA(1)=HB*DQ/(AV(1,N,M)+AV(1,N,MP))*(TSX(N,M)+TSX(N,MP)) 

 2664 FB(1)=1.0 

 2665 ELSE IF(ITOPV.EQ.2)THEN 

 2666 FA(1)=B9*HB*DQ/(AV(1,N,M)+AV(1,N,MP))*(TSX(N,M)+TSX(N,MP)) 

 2667 FB(1)=B10 

 2668 ELSE IF(ITOPV.EQ.3)THEN 

 2669 DP=HISQ*(AV(1,N,M)+AV(1,N,MP)) 

 2670 GP=FNONL*B1*HI*(W(2,N,M)+W(2,N,MP)+W(1,N,M)+W(1,N,MP)) 

 2671 DIFF=RAP*AH3(1,N,MP)*(U(1,N,MP)-U(1,N,M)) 

 2672 1 -RAM*AH3(1,N,M)*(U(1,N,M)-UPMM(1,N)) 

 2673 2 +(1.-BETAC)*(RBP*(U(1,NP,M)-U(1,N,M)+V(1,N,MP)-V(1,N,M)) 

 2674 3 *.25*(AH3(1,N,M)+AH3(1,NP,M)+AH3(1,N,MP)+AH3(1,NP,MP)) 

 2675 4 -RBM*(U(1,N,M)-UPM(1,NM)+V(1,NM,MP)-VPM(1,NM)) 

 2676 5 *.25*(AH3(1,N,M)+AH3(1,NM,M)+AH3(1,N,MP)+AH3(1,NM,MP)) ) 

 2677 UCEN=U(1,N,M)+UE(N,M) 

 2678 VB=(VPM(1,N)+VPM(1,NM)+V(1,N,MP)+V(1,NM,MP))*FAVG 

 2679 ANB=FNONL*((1.-CU)*(HBXP*(U(1,N,MP)+UE(N,MP))**2-HBX*(UCEN)**2) 

 2680 1 +(1.+CU)*(HBX*(UCEN)**2-HBXM*(UPMM(1,N)+UE(N,MM))**2) 

 2681 2 +HCP*(U(1,NP,M)+UE(NP,M)+UCEN)*(V(1,N,M)+VE(N,M) 

 2682 3 +V(1,N,MP)+VE(N,MP))-HCM*(UCEN+UPM(1,NM)+UE(NM,M))*(VPM(1,NM) 

 2683 4 +VE(NM,M)+V(1,NM,MP)+VE(NM,MP)) ) 

 2684 XDT1=.5*DTI*(TSX(N,M)+TSX(N,MP))*HI/DQ 

 2685 DENOM=1./(1.+DELH+2.*(DP-GP)+CFS*ABS(UCEN)) 

 2686 FA(1)=(UPM(1,N)*(1.-DELH)+(XDT-CFS*ABS(UCEN)*UE(N,M) 

 2687 1 -EDGE*DTI*GRX(1)+FCOR*VB+DIFF+ANA-ANB)+XDT1)*DENOM 

 2688 FB(1)=2.*(GP+DP)*DENOM 

 2689 ENDIF 

 2690 C 

 2691 C LOOP THRU THE DEPTHS 

 2692 180 DO 220 L=2,LAYRS 

 2693 DP=HISQ*(AV(L,N,M)+AV(L,N,MP)) 

 2694 DM=HISQ*(AV(L-1,N,M)+AV(L-1,N,MP)) 

 2695 VB=(VPM(L,N)+VPM(L,NM)+V(L,N,MP)+V(L,NM,MP))*FAVG 

 2696 C MOMENTUM DIFFUSION TERMS 

 2697 DIFF=RAP*AH3(L,N,MP)*(U(L,N,MP)-U(L,N,M)) 

 2698 1 -RAM*AH3(L,N,M)*(U(L,N,M)-UPMM(L,N)) 

 2699 2 +(1.-BETAC)*(RBP*(U(L,NP,M)-U(L,N,M)+V(L,N,MP)-V(L,N,M)) 

 2700 3 *.25*(AH3(L,N,M)+AH3(L,NP,M)+AH3(L,N,MP)+AH3(L,NP,MP)) 

 2701 4 -RBM*(U(L,N,M)-UPM(L,NM)+V(L,NM,MP)-VPM(L,NM)) 

 2702 5 *.25*(AH3(L,N,M)+AH3(L,NM,M)+AH3(L,N,MP)+AH3(L,NM,MP)) ) 

 2703 C NON-LINEAR TERMS 

 2704 UCEN=U(L,N,M)+UE(N,M) 

 2705 ANB=FNONL*((1.-CU)*(HBXP*(U(L,N,MP)+UE(N,MP))**2-HBX*(UCEN)**2) 

 2706 1 +(1.+CU)*(HBX*(UCEN)**2-HBXM*(UPMM(L,N)+UE(N,MM))**2) 

 2707 2 +HCP*(U(L,NP,M)+UE(NP,M)+UCEN)* 

 2708 3 (V(L,N,M)+VE(N,M)+V(L,N,MP)+VE(N,MP)) 

 2709 4 -HCM*(UCEN+UPM(L,NM)+UE(NM,M))* 

 2710 5 (VPM(L,NM)+VE(NM,M)+V(L,NM,MP)+VE(NM,MP)) ) 

 2711 GM=FNONL*B1*HI*(W(L-1,N,M)+W(L-1,N,MP)+W(L,N,M)+W(L,N,MP)) 

 2712 GP=FNONL*B1*HI*(W(L+1,N,M)+W(L+1,N,MP)+W(L,N,M)+W(L,N,MP)) 

 2713 C CALCULATE THE RECURSIVE TERMS 

 2714 F1=GM-DM 

 2715 F2=1.+DELH+GM-GP+DM+DP+CFS*ABS(UCEN) 

 2716 F3=-GP-DP 

 2717 F4=UPM(L,N)*(1.-DELH)+XDT-CFS*ABS(UCEN)*UE(N,M)-EDGE*DTI*GRX(L) 

 2718 1 +FCOR*VB+DIFF+ANA-ANB 

 2719 DENOM=1./(F2+F1*FB(L-1)) 

 2720 FA(L)=(F4-F1*FA(L-1))*DENOM 

 2721 FB(L)=(FBC(L)*F1-F3)*DENOM 

 2722 220 CONTINUE 

 2723 C APPLY BOTTOM BOUNDARY CONDITIONS 

 2724 IF(IBOTV.EQ.0)THEN 

 2725 UP(LBOT)=-UE(N,M) 

 2726 ELSE IF(IBOTV.EQ.1)THEN ! FIRST-ORDER 

 2727 RR=DQ*HB*(PHI(N,M)+PHI(N,MP))/(AV(LAYRS,N,M)+AV(LAYRS,N,MP)) 

 2728 UP(LBOT)=(FA(LAYRS)-RR*UE(N,M))/(1.+RR-FB(LAYRS)) 

 2729 ELSE IF(IBOTV.EQ.2)THEN 

 2730 RR=DQ*HB*(PHI(N,M)+PHI(N,MP))/(AV(LAYRS,N,M)+AV(LAYRS,N,MP)) 

 2731 UP(LBOT)=(2.*RR*UE(N,M)+FA(LAYRS-1)-(4.-FB(LAYRS 

 2732 1 -1.))*FA(LAYRS))/((4.-FB(LAYRS-1))*FB(LAYRS)-3.-2.*RR) 

 2733 ELSE IF(IBOTV.EQ.3)THEN ! STRESS AT MID-LEVEL 

 2734 F1=.25*(PHI(N,M)+PHI(N,MP)) 

 2735 F2=.50*(AV(LAYRS,N,M)+AV(LAYRS,N,MP))/(DQ*HB) 

 2736 UP(LBOT)=(FA(LAYRS)*(F2-F1)-2.*F1*UE(N,M))/(F1+F2 

 2737 1 -FB(LAYRS)*(F2-F1)) 

 2738 ENDIF 

 2739 C FIND UPDATED VELOCITY, AND NET VELOCITY 

 2740 270 UNET=HALFDQ*UP(LBOT) 

 2741 DO 280 I=1,LAYRM 

 2742 UP(LBOT-I)=FA(LBOT-I)+FB(LBOT-I)*UP(LBOT-I+1) 

 2743 280 UNET=UNET+DQ*UP(LBOT-I) 

 2744 C SECOND ORDER 
40

 2745 GOTO(290,300,290),ITOPV 

 2746 290 UP(1)=FA(1)+FB(1)*UP(2) 

 2747 GOTO 310 

 2748 300 UP(1)=FB(1)*UP(2)-.33333*UP(3)+FA(1) 

 2749 310 UNET=UNET+HALFDQ*UP(1) 

 2750 C ENFORCE ZERO NET INTERNAL-MODE FLOW 

 2751 DO 320 L=1,LBOT 

 2752 320 U(L,N,M)=UP(L)-UNET*CJ(L) 

 2753 C 

 2754 C Y-DIRECTION INTERNAL MODE VELOCITY 

 2755 C 

 2756 330 IF(IBARR.GE.2)GOTO 540 

 2757 IF(N.EQ.NMAX)GOTO 540 

 2758 IF(IFIELD(N,M).EQ.KOCN.AND.IFIELD(NP,M).EQ.KOCN)GOTO 540 

 2759 C CHECK FOR NON-LINEAR TERMS 

 2760 EDGE=AMIN1(FEDGE(N,M),FEDGE(NP,M)) 

 2761 FNONL=FNONL0 

 2762 IF(EDGE.LT.0.55)FNONL=0. 

 2763 C CHECK FOR CHANNEL:NO=0, YES=1. 

 2764 BETAC=1-IFIX(BY(N,M)) 

 2765 C DEPTH VARIABLES 

 2766 HS=D(N,M)+BETAH*SE(N,M) 

 2767 HP=D(NP,M)+BETAH*SE(NP,M) 

 2768 HPP=HP 

 2769 IF(NP.LT.NMAX)HPP=D(NP+1,M)+BETAH*SE(NP+1,M) 

 2770 HB=.5*(HS+HP) 

 2771 HI=1./(HB+E) 

 2772 CFS=DTI*BETAC*CDRGWS/(DL*BY(N,M)) 

 2773 C TOTAL EXTERNAL RETARDING FORCE 

 2774 YDT=DTI*((TBY(N,M)-.5*(TSY(N,M)+TSY(NP,M)))*HI+EDGE*GSTARY(N,M) 

 2775 1 + (THETSV(N,M))*VE(N,M)) 

 2776 HISQ=B2*HI**2 

 2777 DELH=.25*(SEPP(N,M)+SEPP(NP,M)-SOLD(N,M)-SOLD(NP,M))*HI 

 2778 FAVG=1./(E+FLOAT(MFLUX(N,M))+FLOAT(MFLUX(N,MM)) 

 2779 1 +FLOAT(MFLUX(NP,M))+FLOAT(MFLUX(NP,MM))) 

 2780 FCOR=EDGE*FSPLIT*(FCOR0+DFDM*FLOAT(M-MCOR)+DFDN*FLOAT(N-NCOR)) 

 2781 RAP=B3*HI/BY(N,M)*(BY(N,M)+BY(NP,M)) 

 2782 RAM=B3*HI/BY(N,M)*(BY(N,M)+BY(NM,M)) 

 2783 RBP=B4*HI 

 2784 RBM=B4*HI 

 2785 C NON-LINEAR TERMS 

 2786 CV=SIGN(1.0,VH(N,M)) 

 2787 IF(FNONL.EQ.0.)THEN 

 2788 ANA=0. 

 2789 ELSE 

 2790 F1=B7*HI/BY(N,M) 

 2791 HBYM=F1*BY(NM,M)*(HS+D(NM,M)+BETAH*SE(NM,M)) 

 2792 HBY=F1*BY(N,M)*(HS+HP) 

 2793 HBYP=F1*BY(NP,M)*(HP+HPP) 

 2794 HCP=B8*HI*(HS+HP+D(N,MP)+D(NP,MP)+BETAH*(SE(N,MP)+SE(NP,MP))) 

 2795 HCM=B8*HI*(HS+HP+D(N,MM)+D(NP,MM)+BETAH*(SE(N,MM)+SE(NP,MM))) 

 2796 ANA=B5*HI/BY(N,M)*((1.-CV)*(THETA2(NP,M)*VH(NP,M) 

 2797 1 -THETA2(N,M)*VH(N,M))+(1.+CV)*(THETA2(N,M)*VH(N,M) 

 2798 2 -THETA2(NM,M)*VH(NM,M)))+B6*HI*(THETA3(N,M)-THETA3(N,MM)) 

 2799 ENDIF 

 2800 C APPLY TOP BOUNDARY CONDITIONS 

 2801 IF(ITOPV.EQ.1)THEN 

 2802 FA(1)=HB*DQ/(AV(1,N,M)+AV(1,NP,M))*(TSY(N,M)+TSY(NP,M)) 

 2803 FB(1)=1.0 

 2804 ELSE IF(ITOPV.EQ.2)THEN 

 2805 FA(1)=.66667*HB*DQ/(AV(1,N,M)+AV(1,NP,M))*(TSY(N,M)+TSY(NP,M)) 

 2806 FB(1)=1.33333 

 2807 ELSE IF(ITOPV.EQ.3)THEN 

 2808 DP=HISQ*(AV(1,N,M)+AV(1,NP,M)) 

 2809 GP=FNONL*B1*HI*(W(2,N,M)+W(2,NP,M)+W(1,N,M)+W(1,NP,M)) 

 2810 DIFF=RAP*AH3(1,NP,M)*(V(1,NP,M)-V(1,N,M)) 

 2811 1 -RAM*AH3(1,N,M)*(V(1,N,M)-VPM(1,NM)) 

 2812 2 +(1.-BETAC)*(RBP*(U(1,NP,M)-UPM(1,N)+V(1,N,MP)-V(1,N,M)) 

 2813 3 *.25*(AH3(1,N,M)+AH3(1,NP,M)+AH3(1,N,MP)+AH3(1,NP,MP)) 

 2814 4 -RBM*(UPMM(1,NP)-UPMM(1,N)+V(1,N,M)-VPM(1,N)) 

 2815 5 *.25*(AH3(1,N,M)+AH3(1,NP,M)+AH3(1,N,MM)+AH3(1,NP,MM)) ) 

 2816 VCEN=V(1,N,M)+VE(N,M) 

 2817 UB=(UPM(1,N)+UPMM(1,N)+UPM(1,NP)+UPMM(1,NP))*FAVG 

 2818 ANB=FNONL*((1.-CV)*(HBYP*(V(1,NP,M)+VE(NP,M))**2-HBY*(VCEN)**2) 

 2819 1 +(1.+CV)*(HBY*(VCEN)**2-HBYM*(VPM(1,NM)+VE(NM,M))**2) 

 2820 2 +HCP*(U(1,N,M)+UE(N,M)+U(1,NP,M)+UE(NP,M))*(VCEN 

 2821 3 +V(1,N,MP)+VE(N,MP))-HCM*(UPMM(1,N)+UE(N,MM)+UPMM(1,NP) 

 2822 4 +UE(NP,MM))*(VCEN+VPMM(1,N)+VE(N,MM))) 

 2823 YDT1=.5*DTI*(TSY(N,M)+TSY(NP,M))*HI/DQ 

 2824 DENOM=1./(1.+DELH+2.*(DP-GP)+CFS*ABS(VCEN)) 

 2825 FA(1)=(VPM(1,N)*(1.-DELH)+(YDT-CFS*ABS(VCEN)*VE(N,M) 

 2826 1 -EDGE*DTI*GRY(1)-FCOR*UB+DIFF+ANA-ANB)+YDT1)*DENOM 

 2827 FB(1)=2.*(GP+DP)*DENOM 

 2828 ENDIF 

 2829 C 

 2830 C LOOP THRU THE LAYERS 

 2831 390 DO 430 L=2,LAYRS 

 2832 DP=HISQ*(AV(L,N,M)+AV(L,NP,M)) 

 2833 DM=HISQ*(AV(L-1,N,M)+AV(L-1,NP,M)) 

 2834 UB=(UPM(L,N)+UPMM(L,N)+UPM(L,NP)+UPMM(L,NP))*FAVG 

 2835 C HORIZONTAL DIFFUSION OF MOMENTUM 

 2836 DIFF=RAP*AH3(L,NP,M)*(V(L,NP,M)-V(L,N,M)) 

 2837 1 -RAM*AH3(L,N,M)*(V(L,N,M)-VPM(L,NM)) 

 2838 2 +(1.-BETAC)*(RBP*(U(L,NP,M)-UPM(L,N)+V(L,N,MP)-V(L,N,M)) 

 2839 3 *.25*(AH3(L,N,M)+AH3(L,NP,M)+AH3(L,N,MP)+AH3(L,NP,MP)) 

 2840 4 -RBM*(UPMM(L,NP)-UPMM(L,N)+V(L,N,M)-VPM(L,N)) 

 2841 5 *.25*(AH3(L,N,M)+AH3(L,NP,M)+AH3(L,N,MM)+AH3(L,NP,MM)) ) 

 2842 C NON-LINEAR TERMS 

 2843 VCEN=V(L,N,M)+VE(N,M) 

 2844 ANB=FNONL*((1.-CV)*(HBYP*(V(L,NP,M)+VE(NP,M))**2-HBY*(VCEN)**2) 

 2845 1 +(1.+CV)*(HBY*(VCEN)**2-HBYM*(VPM(L,NM)+VE(NM,M))**2) 

 2846 2 +HCP*(U(L,N,M)+UE(N,M)+U(L,NP,M)+UE(NP,M))* 

 2847 3 (VCEN+V(L,N,MP)+VE(N,MP)) 

 2848 4 -HCM*(UPMM(L,N)+UE(N,MM)+UPMM(L,NP)+UE(NP,MM))* 

 2849 5 (VCEN+VPMM(L,N)+VE(N,MM))) 

 2850 GM=FNONL*B1*HI*(W(L-1,N,M)+W(L-1,NP,M)+W(L,N,M)+W(L,NP,M)) 

 2851 GP=FNONL*B1*HI*(W(L+1,N,M)+W(L+1,NP,M)+W(L,N,M)+W(L,NP,M)) 

 2852 C COMPUTE THE RECURSIVE ARRAYS 

 2853 F1=GM-DM 

 2854 FS=CFS*ABS(VCEN) 

 2855 F2=1.+DELH+GM-GP+DM+DP+FS 

 2856 F3=-GP-DP 

 2857 F4=VPM(L,N)*(1.-DELH)+YDT-FS*VE(N,M)-EDGE*DTI*GRY(L)-FCOR*UB+DIFF 

 2858 1 +ANA-ANB 

 2859 DENOM=1./(F2+F1*FB(L-1)) 

 2860 FA(L)=(F4-F1*FA(L-1))*DENOM 

 2861 FB(L)=(FBC(L)*F1-F3)*DENOM 

 2862 430 CONTINUE 

 2863 C APPLY BOTTOM BOUNDARY CONDITIONS 

 2864 IF(IBOTV.EQ.0)THEN 

 2865 VP(LBOT)=-VE(N,M) 

 2866 ELSE IF(IBOTV.EQ.1)THEN ! FIRST ORDER 

 2867 RR=DQ*HB*(PHI(N,M)+PHI(NP,M))/(AV(LAYRS,N,M)+AV(LAYRS,NP,M)) 

 2868 VP(LBOT)=(FA(LAYRS)-RR*VE(N,M))/(1.+RR-FB(LAYRS)) 

 2869 ELSE IF(IBOTV.EQ.2)THEN ! SECOND ORDER 

 2870 RR=DQ*HB*(PHI(N,M)+PHI(NP,M))/(AV(LAYRS,N,M)+AV(LAYRS,NP,M)) 

 2871 VP(LBOT)=(2.*RR*VE(N,M)+FA(LAYRS-1)-(4.-FB(LAYRS 

 2872 1 -1.))*FA(LAYRS))/((4.-FB(LAYRS-1))*FB(LAYRS)-3.-2.*RR) 

 2873 ELSE IF(IBOTV.EQ.3)THEN ! STRESS AT MID-LEVEL 

 2874 F1=.25*(PHI(N,M)+PHI(NP,M)) 

 2875 F2=.50*(AV(LAYRS,N,M)+AV(LAYRS,NP,M))/(DQ*HB) 

 2876 VP(LBOT)=(FA(LAYRS)*(F2-F1)-2.*F1*VE(N,M))/(F1+F2 

 2877 1 -FB(LAYRS)*(F2-F1)) 

 2878 END IF 

 2879 C FIND UPDATED VELOCITY AND NET VELOCITY 

 2880 480 UNET=HALFDQ*VP(LBOT) 

 2881 DO 490 I=1,LAYRM 

 2882 VP(LBOT-I)=FA(LBOT-I)+FB(LBOT-I)*VP(LBOT-I+1) 

 2883 490 UNET=UNET+DQ*VP(LBOT-I) 

 2884 GOTO(500,510,500),ITOPV 

 2885 500 VP(1)=FA(1)+FB(1)*VP(2) 

 2886 GOTO 520 

 2887 510 VP(1)=FB(1)*VP(2)-.33333*VP(3)+FA(1) 

 2888 520 UNET=UNET+HALFDQ*VP(1) 

 2889 C ENFORCE ZERO NET FLO 

 2890 DO 530 L=1,LBOT 

 2891 530 V(L,N,M)=VP(L)-UNET*CJ(L) 

 2892 C 

 2893 540 CONTINUE 

 2894 545 CONTINUE 

 2895 550 CONTINUE 

 2896 C 

 2897 660 CONTINUE 

 2898 RETURN 

 2899 END 

 2900 C 

 2901 C----------------------------------------------------------------------- 

 2902 C 

 2903 SUBROUTINE VERVIS 

 2904 C SEPTEMBER 1987 MEAD K.W.HESS VAX 11/780 

 2905 C PURPOSE - TO UPDATE ALL VERTICAL EXCHANGE COEFFICIENTS. 

 2906 C USE THE MONK AND ANDERSON FORMULATION. 

 2907 C VARIABLES - 

 2908 C INDEX = RUN UPDATE INDEX:0=RESTART CONDITION,1=NORMAL 

 2909 C RICHNO = RICHARDSON NUMBER = {D(RHO)/DZ}/{(DU/DZ**2)*RHO*G}

 2910 INCLUDE 'COMM20.FOR' 

 2911 COMMON/A1/DTIMAX 

 2912 BETAH=MAX0(0,MIN0(1,IBETAH)) 

 2913 IF(NSTI.EQ.1)DTIMAX=1.E+10 

 2914 C SET VERTICAL DENSITY CHANGE (GM/CC) PER METER 

 2915 DO 130 M=1,MMAX 

 2916 DO 120 N=1,NMAX 

 2917 IF(IFIELD(N,M).LE.0)GOTO 120 

 2918 AVMAX=0.0 

 2919 MM=MAX0(M-1,1) 

 2920 MP=MIN0(M+1,MMAX) 

 2921 NM=MAX0(N-1,1) 

 2922 NP=MIN0(N+1,NMAX) 

 2923 HS=AMAX1(1.0,D(N,M)+BETAH*SE(N,M)) 

 2924 F1=-AG/(HS*DQ) 

 2925 F2=1./(HS*DQ) 

 2926 C ESTABLISH WEIGHTING FACTORS FOR VELOCITY 

 2927 FD=1./AMAX1(1.414,FLOAT(MFLUX(N,M)+MFLUX(N,MM))) 

 2928 FX1=FLOAT(MFLUX(N,M))*FD 

 2929 IF(M.EQ.1)FX1=1.0 

 2930 FX2=FLOAT(MFLUX(N,MM))*FD 

 2931 FD=1./AMAX1(1.414,FLOAT(NFLUX(N,M)+NFLUX(NM,M))) 

 2932 FY1=FLOAT(NFLUX(N,M))*FD 

 2933 IF(N.EQ.1)FY1=1.0 

 2934 FY2=FLOAT(NFLUX(NM,M))*FD 

 2935 C LOOP THRU LAYERS 

 2936 DO 100 L=1,LAYRS 

 2937 FAV=0. 

 2938 FDV=0. 

 2939 Q=ABS(FLOAT(1-L)*DQ-HALFDQ) 

 2940 c mixing length for momentum diffusivity 

 2941 Z1=VONKAR*HS*(1.-Q)*Q**CR0 

 2942 C GET VELOCITY GRADIENT 

 2943 DUM=U(L,N,MM)-U(L+1,N,MM) 

 2944 IF(M.EQ.1)DUM=0.0 

 2945 DVM=V(L,NM,M)-V(L+1,NM,M) 

 2946 IF(N.EQ.1)DVM=0.0 

 2947 DELU=FX1*(U(L,N,M)-U(L+1,N,M))+FX2*(DUM) 

 2948 DELV=FY1*(V(L,N,M)-V(L+1,N,M))+FY2*(DVM) 

 2949 DUDZ= SQRT(DELU**2+DELV**2)*F2+E 

 2950 C GET DENSITY GRADIENT PER UNIT DENSITY 

 2951 IF(ICOUPL.GT.0)THEN 

 2952 DELTA=FRHO(S(L,N,M),T(L,N,M))-FRHO(S(L+1,N,M),T(L+1,N,M)) 

 2953 ELSE 

 2954 DELRHO=0.0000 

 2955 DELTA=DELRHO*HS*DQ 

 2956 END IF 

 2957 C NEW RICHARDSON NUMBER: ALLOWS FOR NEGATIVE RI 

 2958 RICHNO=RAMPG*F1*DELTA/(DUDZ**2) 

 2959 RICHNO=AMAX1(RIMIN,AMIN1(RIMAX,RICHNO)) 

 2960 RI(L,N,M)=RICHNO 

 2961 IF(RICHNO.GT.0.0)THEN 

 2962 FAV=CRICH(1)*(1.+CRICH(2)*RICHNO)**(-CRICH(3)) 

 2963 FDV=CRICH(5)*(1.+CRICH(6)*RICHNO)**(-CRICH(7)) 

 2964 ELSE 

 2965 FAV=CRICH(1)*(1.+CRICH(4)*RICHNO**2) 

 2966 FDV=CRICH(5)*(1.+CRICH(8)*RICHNO**2) 

 2967 ENDIF 

 2968 90 VISNEW=AV0+FAV*DUDZ*Z1**2 

 2969 DIFNEW=DV0+FDV*DUDZ*Z1**2 

 2970 C UPDATE 

 2971 IF(AV(L,N,M).EQ.0.0)THEN 

 2972 AV(L,N,M)=VISNEW 

 2973 ELSE 

 2974 AV(L,N,M)=SQRT(AV(L,N,M)*VISNEW) 

 2975 END IF 

 2976 IF(DV(L,N,M).EQ.0.0)THEN 

 2977 DV(L,N,M)=DIFNEW 

 2978 ELSE 

 2979 DV(L,N,M)=SQRT(DV(L,N,M)*DIFNEW) 

 2980 END IF 

 2981 100 IF(L.GT.1)AVMAX=AMAX1(AVMAX,AV(L,N,M)) 

 2982 C UPDATE SCALE EXPLICIT INTERNAL-MODE TIMESTEP BASED ON DIFFUSION 

 2983 IF(HR.GT.HRCON2.AND.AVMAX.GT.0.0)DTIMAX=AMIN1(DTIMAX, 

 2984 1 .25*(DQ*HS)**2/AVMAX) 

 2985 120 CONTINUE 

 2986 130 CONTINUE 

 2987 C LOOP THRU OCEANIC BOUNDARIES 

 2988 IF(NUMOBC.LE.0)RETURN 

 2989 DO 200 IB=1,NUMOBC 

 2990 DO 200 N=NB1(IB),NB2(IB) 

 2991 DO 200 M=MB1(IB),MB2(IB) 

 2992 MP=M 

 2993 IF(IABS(ITPO(IB)).EQ.1)MP=M-ISIGN(1,ITPO(IB)) 

 2994 NP=N 

 2995 IF(IABS(ITPO(IB)).EQ.2)NP=N-ISIGN(1,ITPO(IB)) 

 2996 DO L=1,LAYRS 
41

 2997 AV(L,N,M)=AV(L,NP,MP) 

 2998 DV(L,N,M)=DV(L,NP,MP) 

 2999 ENDDO 

 3000 200 CONTINUE 

 3001 IF(IPRNT1.GT.0)WRITE(ISCR,*)'UT=',UT,' DTIMAX=',DTIMAX 

 3002 IF(IPRNT1.GT.0)WRITE(ISCR,*)'AVMAX=',AVMAX 

 3003 RETURN 

 3004 END 

 3005 C 

 3006 C----------------------------------------------------------------------- 

 3007 C 

 3008 SUBROUTINE WVERT 

 3009 C MARCH 1986 K.W. HESS MEAD VAX 11/750 

 3010 C PURPOSE - TO CALCULATE W, THE PRODUCT OF H AND DQ/DTI 

 3011 INCLUDE 'COMM20.FOR' 

 3012 C SET CONSTANTS 

 3013 F1=.25*DQ/DL 

 3014 KOCN=10*KOCNBC 

 3015 C LOOP THRU THE GRID MESH 

 3016 DO 140 M=1,MMAX 

 3017 NA=NAB(M)/1000 

 3018 NB=NAB(M)-1000*NA 

 3019 MM=MAX0(M-1,1) 

 3020 MP=MIN0(M+1,MMAX) 

 3021 IF(NA.GT.NB)GOTO 140 

 3022 DO 130 N=NA,NB 

 3023 IF(IFIELD(N,M)/10.LT.1.OR.IFIELD(N,M)/10.EQ.KOCNBC)GOTO 130 

 3024 C WATER GRID HERE 

 3025 HC=D(N,M)+SE(N,M) 

 3026 F2=F1/AREA(N,M) 

 3027 HMP=F2*BX(N,M)*(HC+D(N,MP)+SE(N,MP)) 

 3028 HMM=F2*BX(N,MM)*(HC+D(N,MM)+SE(N,MM)) 

 3029 NP=MIN0(N+1,NMAX) 

 3030 NM=MAX0(N-1,1) 

 3031 HNP=F2*BY(N,M)*(HC+D(NP,M)+SE(NP,M)) 

 3032 HNM=F2*BY(NM,M)*(HC+D(NM,M)+SE(NM,M)) 

 3033 C WC IS THE PRODUCT OF THE DEPTH AND THE DIMENSIONLESS VERT. VEL. 

 3034 WC(LBOT)=0.0 

 3035 DO 100 L=LAYRS,1,-1 

 3036 100 WC(L)=WC(L+1)-(HMP*(U(L,N,M)+U(L+1,N,M))-HMM*(U(L,N,MM) 

 3037 1 +U(L+1,N,MM))+HNP*(V(L,N,M)+V(L+1,N,M))-HNM*(V(L,NM,M) 

 3038 2 +V(L+1,NM,M))) 

 3039 C GET THE ADJUSTED DIMENSIONLESS VERTICAL VELOCITY 

 3040 DO 110 L=1,LBOT 

 3041 110 W(L,N,M)=WC(L)-WC(1)*FLOAT(LBOT-L)*DQ 

 3042 130 CONTINUE 

 3043 140 CONTINUE 

 3044 RETURN 

 3045 END 

 3046 c======================================================================= 

 3047 c MECCA: FORCES 

 3048 C----------------------------------------------------------------------- 

 3049 C 

 3050 SUBROUTINE FORCES 

 3051 

 3052 C APRIL 1988 K. W. HESS MEAD VAX11/750 

 3053 C PURPOSE - TO SET THE INTERFACIAL STRESS TERMS: 

 3054 C BOTTOM STRESS AND WIND STRESS AND AIR TEMPERATURE 

 3055 INCLUDE 'COMM20.FOR' 

 3056 C GET WIND STRESS AND AIR TEMPERATURE 

 3057 IF(NSTE.EQ.1)CALL ATMOS 

 3058 C UPDATE BOTTOM STRESS 

 3059 CALL BSTRES 

 3060 C UPDATE EXTERNAL PRESSURE GRADIENTS 

 3061 CALL ALGRAD 

 3062 RETURN 

 3063 END 

 3064 C 

 3065 C----------------------------------------------------------------------- 

 3066 C 

 3067 SUBROUTINE ATMOS 

 3068 C APRIL 1996 K. W. HESS CEOB SGI/IRIS 

 3069 C PURPOSE - TO SET THE WIND STRESS AND AIR TEMPERATURE 

 3070 C VARIABLES - 

 3071 INCLUDE 'COMM20.FOR' 

 3072 COMMON/METOX/TMET8(2),ITYPE1 

 3073 REAL*8 TMET8,FA8,FB8 

 3074 RAMPW=AMIN1(1.0,CUMDAY) 

 3075 c initialize 

 3076 IF(NSIGW.GT.0.AND.IENDWN.EQ.0)GOTO 100 

 3077 DPADX=0.0 

 3078 DPADY=0.0 

 3079 DO N=1,NMAX 

 3080 DO M=1,MMAX 

 3081 TSX(N,M)=0 

 3082 TSY(N,M)=0 

 3083 ENDDO 

 3084 ENDDO 

 3085 IF(NSIGW.EQ.0)RETURN 

 3086 IF(IENDWN.EQ.1)THEN 

 3087 WRITE(6,*)' NO MORE GRIDDED WIND DATA' 

 3088 RETURN 

 3089 ENDIF 

 3090 c check for time of available data 

 3091 100 CONTINUE 

 3092 IF(IPRNT1.EQ.1)WRITE(6,105)TMET8(1),YT,TMET8(2) 

 3093 105 FORMAT(5X,'TMET8(1)=',F12.7,' YT=',F12.7,' TMET8(2)=',F12.7) 

 3094 110 IF(YT.GT.TMET8(2))THEN 

 3095 c save 

 3096 TMET8(1)=TMET8(2) 

 3097 DO N=1,NMAX 

 3098 DO M=1,MMAX 

 3099 FX(1,N,M)=FX(2,N,M) 

 3100 FY(1,N,M)=FY(2,N,M) 

 3101 ENDDO 

 3102 ENDDO 

 3103 c set default values 

 3104 DO N=1,NMAX 

 3105 DO M=1,MMAX 

 3106 FX(2,N,M)=0 

 3107 FY(2,N,M)=0 

 3108 ENDDO 

 3109 ENDDO 

 3110 c read next array 

 3111 I=2 

 3112 CALL RDWIND(I,IEND) 

 3113 IF(IEND.EQ.1)RETURN 

 3114 IF(IPRNT1.EQ.1)WRITE(6,105)TMET8(1),YT,TMET8(2) 

 3115 GOTO 110 

 3116 ENDIF 

 3117 c get interpolated stress 

 3118 FB8=(YT-TMET8(1))/(TMET8(2)-TMET8(1)) 

 3119 F2=FB8 

 3120 FA8=1.-FB8 

 3121 F1=FA8 

 3122 IF(IPRNT1.EQ.1)WRITE(6,*)' F1,2, ITYPE1=',F1,F2,ITYPE1 

 3123 DO N=1,NMAX 

 3124 DO M=1,MMAX 

 3125 TSX(N,M)=RAMPW*(F1*FX(1,N,M)+F2*FX(2,N,M)) 

 3126 TSY(N,M)=RAMPW*(F1*FY(1,N,M)+F2*FY(2,N,M)) 

 3127 IF(ITYPE1.EQ.1)THEN 

 3128 W1=TSX(N,M) 

 3129 W2=TSY(N,M) 

 3130 W10=SQRT(W1**2+W2**2) 

 3131 CDRGAW=CDR1+CDR2*W10 

 3132 TSX(N,M)=DENRAT*CDRGAW*W10*W1 

 3133 TSY(N,M)=DENRAT*CDRGAW*W10*W2 

 3134 WX(N,M)=W1 

 3135 WY(N,M)=W2 

 3136 ENDIF 

 3137 ENDDO 

 3138 ENDDO 

 3139 c adjust atmospheric pressure gradient 

 3140 DPADX=RAMPW*DPADX 

 3141 DPADY=RAMPW*DPADY 

 3142 c adjust for shallow water 

 3143 IF(DTAU2.LT.0.0)GOTO 130 

 3144 DO 120 M=1,MMAX 

 3145 DO 120 N=1,NMAX 

 3146 IF(MFLUX(N,M).EQ.1)THEN 

 3147 DEFF=AMIN1(D(N,M)+SE(N,M),D(N,M+1)+SE(N,M+1)) 

 3148 FACTOR=AMAX1(0.0, AMIN1(1.,(DEFF-DTAU1)/(DTAU2-DTAU1))) 

 3149 TSX(N,M)=TSX(N,M)*FACTOR 

 3150 ENDIF 

 3151 IF(NFLUX(N,M).EQ.1)THEN 

 3152 DEFF=AMIN1(D(N,M)+SE(N,M),D(N+1,M)+SE(N+1,M)) 

 3153 FACTOR=AMAX1(0.0, AMIN1(1.,(DEFF-DTAU1)/(DTAU2-DTAU1))) 

 3154 TSY(N,M)=TSY(N,M)*FACTOR 

 3155 ENDIF 

 3156 120 CONTINUE 

 3157 130 CONTINUE 

 3158 RETURN 

 3159 END 

 3160 C 

 3161 C----------------------------------------------------------------------- 

 3162 C 

 3163 SUBROUTINE BSTRES 

 3164 C SEPTEMBER 1996 K. W. HESS 

 3165 C PURPOSE - TO UPDATE THE BOTTOM STRESS. TBX IS AT LOCATION 

 3166 C OF UH, TBY IS AT VH. 

 3167 C VARIABLES - 

 3168 C IBOTV = BOTTOM CONDITION INDEX 

 3169 C 0 = NON-SLIP 

 3170 C 1 = SLIP, FIRST ORDER 

 3171 C 2 = SLIP, SECOND ORDER 

 3172 C 3 = LOG LAYER 

 3173 INCLUDE 'COMM20.FOR' 

 3174 DIMENSION UTO(NSIZE,MSIZE),VTO(NSIZE,MSIZE) 

 3175 DATA Z0/0.003/ 

 3176 C SELECT WEIGHTING FACTOR FOR OLD VS. NEW STRESS 

 3177 FNEW=1. 

 3178 FOLD=1.-FNEW 

 3179 C COMPUTE THE WEIGHTING FACTORS FOR NO-SLIP AND LOG-LAYER STRESS 

 3180 GAMMA=1. 

 3181 IF(IBOTV.EQ.0)GAMMA=.0 

 3182 IF(IBOTV.EQ.3)GAMMA=.5 

 3183 C COMPUTE THE TOTAL BOTTOM VELOCITY 

 3184 DO M=1,MMAX 

 3185 DO N=1,NMAX 

 3186 UTO(N,M)=UE(N,M)+GAMMA*U(LBOT,N,M)+(1.-GAMMA)*U(LBOT-1,N,M) 

 3187 VTO(N,M)=VE(N,M)+GAMMA*V(LBOT,N,M)+(1.-GAMMA)*V(LBOT-1,N,M) 

 3188 ENDDO 

 3189 ENDDO 

 3190 C COMPUTE THE EFFECTIVE BOTTOM DRAG COEFFICIENT, PHI 

 3191 DO 110 M=1,MMAX 

 3192 DO 110 N=1,NMAX 

 3193 IF(IFIELD(N,M).LT.10)GOTO 110 

 3194 MM=MAX0(M-1,1) 

 3195 NM=MAX0(N-1,1) 

 3196 C DRAG COEFFICIENT AT GRID CENTER BASED ON LOCAL VELOCITY 

 3197 UB=(UTO(N,M)+UTO(N,MM))/(FLOAT(MFLUX(N,M)+MFLUX(N,MM))+E) 

 3198 VB=(VTO(N,M)+VTO(NM,M))/(FLOAT(NFLUX(N,M)+NFLUX(NM,M))+E) 

 3199 c zero bottom velocity 

 3200 IF(IBOTV.EQ.0)THEN 

 3201 PHI(N,M)=AV(LAYRS,N,M)/((D(N,M)+E)*DQ) 

 3202 c log layer 

 3203 ELSE IF(IBOTV.EQ.3)THEN 

 3204 PHI(N,M)=(0.4/ALOG(.5*D(N,M)*DQ/Z0))**2*SQRT(UB**2+VB**2) 

 3205 ELSE 

 3206 PHI(N,M)=CDWB1+CDWB2*SQRT(UB**2+VB**2) 

 3207 ENDIF 

 3208 110 CONTINUE 

 3209 C STRESS 

 3210 DO 140 M=1,MMAX 

 3211 MP=MIN0(M+1,MMAX) 

 3212 DO 140 N=1,NMAX 

 3213 IF(IFIELD(N,M).LT.10)GOTO 140 

 3214 NP=MIN0(N+1,NMAX) 

 3215 TNEWX=.5*(PHI(N,M)+PHI(N,MP))*UTO(N,M) 

 3216 TNEWY=.5*(PHI(N,M)+PHI(NP,M))*VTO(N,M) 

 3217 C TIME AVERAGE 

 3218 TBX(N,M)=FOLD*TBX(N,M)+FNEW*TNEWX 

 3219 TBY(N,M)=FOLD*TBY(N,M)+FNEW*TNEWY 

 3220 140 CONTINUE 

 3221 150 CONTINUE 

 3222 RETURN 

 3223 END 

 3224 C 

 3225 C---------------------------------------------------------------------- 

 3226 C 

 3227 SUBROUTINE ALGRAD 

 3228 C APRIL 1988 HESS MEAD VAX 

 3229 C PURPOSE - TO SET ALL HORIZONTAL DENSITY GRADIENTS 

 3230 INCLUDE 'COMM20.FOR' 

 3231 C SET THE INTERNAL PRESSURE RAMP FACTOR 

 3232 RAMPG=AMAX1(0.,AMIN1(1.,(HR1-HRCON1)/(HRCON2-HRCON1))) 

 3233 C SET INITIAL DENSITY GRADIENTS 

 3234 IF(KONCEN.EQ.0)GOTO 330 

 3235 DO 320 M=1,MMAX 

 3236 DO 320 N=1,NMAX 

 3237 IF(IFIELD(N,M).LT.10)GOTO 320 

 3238 IBARR=MOD(IFIELD(N,M),10) 

 3239 IF(IBARR.EQ.3)GOTO 320 

 3240 CALL GRADP(N,M,1) 

 3241 320 CONTINUE 

 3242 330 CONTINUE 

 3243 RETURN 

 3244 END 

 3245 C======================================================================= 

 3246 C MECCA FILE : MREAD 

 3247 C----------------------------------------------------------------------- 

 3248 C 
42

 3249 SUBROUTINE READZ 

 3250 

 3251 C APRIL 1988 K. W. HESS MEAD VAX 11/750 

 3252 C PURPOSE - TO READ IN RUN-TIME FILE NAMES IN AN INTERACTIVE 

 3253 C MODE 

 3254 INCLUDE 'COMM20.FOR' 

 3255 C ZERO OUT INITIAL ARRAYS 

 3256 CALL ZEROS 

 3257 C OPEN FILE AND READ THE CONTROL FILE 

 3258 LUCON=LUKB 

 3259 RAD=PI/180. 

 3260 DENRAT=RHOA/RHOW 

 3261 CALL RDCON1(JTEST,IVER) 

 3262 CALL RDCON2(JTEST,IVER) 

 3263 CALL RDCON3(JTEST,IVER) 

 3264 C OPEN OUTPUT PRINT FILE 

 3265 CALL FFOPEN(IO,FPRINT) 

 3266 C OPEN GRAPHING FILES 

 3267 IF(IGPH.GT.0)CALL FFOPEN(LUGRF,FGRAPH) 

 3268 C OPEN GEOGRAPHY FILE 

 3269 CALL FFOPEN(LUCON,FGEO) 

 3270 CALL RDGEO(LUCON) 

 3271 CLOSE (LUCON) 

 3272 C GET INITIAL CONDITIONS 

 3273 NSTI=0 

 3274 NSTE=0 

 3275 NSTIT=0 

 3276 NSTET=0 

 3277 HR0=0.0 

 3278 UT1=UT0 

 3279 YEAR1=YEAR 

 3280 IF(ICS.EQ.1)THEN 

 3281 CALL RDICS 

 3282 HR0=FLOAT(NSTET)*DTE/3600. 

 3283 CUMDAY=HR0/24. 

 3284 NSTIT=NSTET/ISPLIT 

 3285 ENDIF 

 3286 RETURN 

 3287 END 

 3288 C 

 3289 C--------------------------------------------------------------------- 

 3290 C 

 3291 SUBROUTINE RDCON1(JTEST,IVER) 

 3292 C OCTOBER 1984 K. HESS MEAD VAX 11/70 (REV 8-89) 

 3293 C PURPOSE - TO READ IN THE CONTROL FILE 

 3294 INCLUDE 'COMM20.FOR' 

 3295 DIMENSION MXNX(NPMSIZ) 

 3296 C THIS IS FOR CON FILE VERSIONS 4 - 5 (8-89) 

 3297 JVER1=4 

 3298 JVER2=5 

 3299 IUNIT=LUCON 

 3300 C READ DATA FILE HERE 

 3301 READ(IUNIT,100)CTITLE 

 3302 100 FORMAT(8A10) 

 3303 WRITE(ISCR,101)CTITLE 

 3304 101 FORMAT(5X,'CON FILE TITLE: ',8A10) 

 3305 READ(IUNIT,103)FGEO 

 3306 103 FORMAT(A40) 

 3307 READ(IUNIT,*)IVER,JTEST,KTEST 

 3308 WRITE(ISCR,*)IVER,JTEST,KTEST 

 3309 WRITE(ISCR,105)FGEO 

 3310 105 FORMAT(5X,'GEOGRAPHY FILE: ',A40) 

 3311 C 

 3312 C READ MODEL CONFIGURATION DATA 

 3313 IF(JTEST.EQ.1)WRITE(ISCR,108) 

 3314 108 FORMAT(1X,'MODEL CONFIGURATION PARAMETERS') 

 3315 READ(IUNIT,1002) 

 3316 1001 FORMAT(1X) 

 3317 1002 FORMAT(/,1X) 

 3318 1100 READ(IUNIT,*,ERR=1108)HRMAX,HROUT,HROUT0,HRSAVE 

 3319 IF(JTEST.EQ.1)PRINT*,HRMAX,HROUT,HROUT0,HRSAVE 

 3320 GOTO 1109 

 3321 1108 WRITE(ISCR,1107) 

 3322 1107 FORMAT(5X,'*** (RDCON) ERROR READING HRMAX, ETC. ***') 

 3323 1109 CONTINUE 

 3324 READ(IUNIT,1001) 

 3325 READ(IUNIT,*,ERR=1118)DTE,ISPLIT,LAYRS 

 3326 DTI=ISPLIT*DTE 

 3327 IF(JTEST.EQ.1)PRINT*,DTE,ISPLIT,LAYRS 

 3328 GOTO 1119 

 3329 1118 WRITE(ISCR,1117) 

 3330 1117 FORMAT(5X,'*** (RDCON) ERROR READING DTE, ISPLIT, ETC. ***') 

 3331 1119 CONTINUE 

 3332 NDZM=LSIZE-1 

 3333 c IF(LAYRS.GE.3.AND.LAYRS.LE.NDZM)GOTO 1122 

 3334 c WRITE(ISCR,1120)LAYRS,NDZM 

 3335 c1120 FORMAT(1X,'*** ERROR: LAYRS=',I3,' IS NOT BETWEEN 3 AND ',I3) 

 3336 c STOP 

 3337 1122 CONTINUE 

 3338 C TURBULENCE VARIABLES 

 3339 DHAH=1.0 

 3340 READ(IUNIT,1001) 

 3341 READ(IUNIT,*,ERR=1217)AH00,AH0,CAH,DHAH,RIMIN,RIMAX 

 3342 IF(JTEST.EQ.1)PRINT*,AH00,AH0,CAH,DHAH,RIMIN,RIMAX 

 3343 GOTO 1220 

 3344 1217 WRITE(ISCR,1218) 

 3345 1218 FORMAT(5X,'*** (RDCON) ERROR READING AHO, CAH ***') 

 3346 1220 READ(IUNIT,*,ERR=1222)AV00,AV0,(CRICH(I),I=1,4) 

 3347 IF(JTEST.EQ.1)PRINT*,AV00,AV0,(CRICH(I),I=1,4) 

 3348 GOTO 1224 

 3349 1222 WRITE(ISCR,1223) 

 3350 1223 FORMAT(5X,'*** (RDCON) ERROR READING AV0, CRICH1, ETC ***') 

 3351 1224 READ(IUNIT,*,ERR=1226)DV00,DV0,(CRICH(I),I=5,8) 

 3352 IF(JTEST.EQ.1)PRINT*,DV00,DV0,(CRICH(I),I=5,8) 

 3353 GOTO 1230 

 3354 1226 WRITE(ISCR,1227) 

 3355 1227 FORMAT(5X,'*** (RDCON) ERROR READING DV0 CRICH3, ETC ***') 

 3356 C UPDATE INTERVALS 

 3357 1230 READ(IUNIT,*,ERR=1255)IHVISC,IVISC,CR0 

 3358 IF(JTEST.EQ.1)PRINT*,IHVISC,IVISC,CR0 

 3359 GOTO 128 

 3360 1255 WRITE(ISCR,1256) 

 3361 1256 FORMAT(5X,'*** (RDCON) ERROR READING IHVISC, IVISC. ***') 

 3362 C DRAG COEFFICIENTS 

 3363 128 READ(IUNIT,1001) 

 3364 READ(IUNIT,*,ERR=1231)CDWB1,CDWB2,CDRGWS,CDR1,CDR2 

 3365 IF(JTEST.EQ.1)PRINT*,CDWB1,CDWB2,CDRGWS,CDR1,CDR2 

 3366 GOTO 1234 

 3367 1231 WRITE(ISCR,1232) 

 3368 1232 FORMAT(5X,'*** (RDCON) ERROR READING CDWB1, CDWB2,CDRGWS ***') 

 3369 C HEATING CONSTANTS 

 3370 1234 READ(IUNIT,1001) 

 3371 READ(IUNIT,*,ERR=1240)ALB,D10PCT 

 3372 IF(JTEST.EQ.1)PRINT*,ALB,D10PCT 

 3373 GOTO 1245 

 3374 1240 WRITE(ISCR,1244) 

 3375 1244 FORMAT(5X,'*** (RDCON) ERROR READING CLOUD, RH ***') 

 3376 C SWITCHES 

 3377 1245 READ(IUNIT,1001) 

 3378 READ(IUNIT,*,ERR=1260)ICOR,IBETAA,IBETAP,IBETAH 

 3379 IF(JTEST.EQ.1)PRINT*,ICOR,IBETAA,IBETAP,IBETAH 

 3380 GOTO 1270 

 3381 1260 WRITE(ISCR,1262) 

 3382 1262 FORMAT(5X,'*** (RDCON) ERROR READING ICOR, ETC. ***') 

 3383 1270 READ(IUNIT,*,ERR=1272)IEXTRN,INTER,KONCEN,ICOUPL 

 3384 IF(JTEST.EQ.1)PRINT*,IEXTRN,INTER,KONCEN,ICOUPL 

 3385 GOTO 1280 

 3386 1272 WRITE(ISCR,1274) 

 3387 1274 FORMAT(5X,'*** (RDCON) ERROR READING IEXTRN, ETC. ***') 

 3388 1280 READ(IUNIT,*,ERR=1285)ITOPV,IBOTV,IHEAT,ICPOS 

 3389 IF(JTEST.EQ.1)PRINT*,ITOPV,IBOTV,IHEAT,ICPOS 

 3390 GOTO 1290 

 3391 1285 WRITE(ISCR,1287) 

 3392 1287 FORMAT(5X,'*** (RDCON) ERROR READING IHEAT, ETC. ***') 

 3393 1290 CONTINUE 

 3394 C READ PRINT PARAMETERS 

 3395 136 CONTINUE 

 3396 IF(JTEST.EQ.1)WRITE(ISCR,135) 

 3397 135 FORMAT(1X,'MODEL PRINT PARAMETERS') 

 3398 READ(IUNIT,1002) 

 3399 C PLAN VIEW VARIABLES 

 3400 READ(IUNIT,*,ERR=137)(JPRNT(I),I=1,13) 

 3401 IF(JTEST.EQ.1)PRINT*,(JPRNT(I),I=1,13) 

 3402 GOTO 1390 

 3403 137 WRITE(ISCR,138) 

 3404 138 FORMAT(5X,'*** (RDCON) ERROR READING JPRNT, ETC. ***') 

 3405 C PAGE FORMATS 

 3406 1390 READ(IUNIT,1001) 

 3407 READ(IUNIT,*,ERR=1392)KPRNT1,KPRNT2 

 3408 IF(JTEST.EQ.1)PRINT*,KPRNT1,KPRNT2 

 3409 GOTO 140 

 3410 1392 WRITE(ISCR,1394) 

 3411 1394 FORMAT(5X,'*** (RDCON) ERROR READING IEXTRN, ETC. ***') 

 3412 C PRINT AT ALL LEVELS 

 3413 140 READ(IUNIT,1001) 

 3414 READ(IUNIT,*,ERR=141)NPRMN 

 3415 IF(JTEST.EQ.1)PRINT*,NPRMN 

 3416 GOTO 144 

 3417 141 WRITE(ISCR,142) 

 3418 142 FORMAT(5X,'*** (RDCON) ERROR READING NPRMN, ETC. ***') 

 3419 144 IF(NPRMN.LE.NDPRN)GOTO 146 

 3420 WRITE(ISCR,145)NPRMN,NDPRNN 

 3421 145 FORMAT(1X,'*** ERROR: NPRMN=',I2,' GREATER THAN NDPRN=',I2) 

 3422 STOP 

 3423 146 CONTINUE 

 3424 IF(NPRMN.GT.0)READ(IUNIT,*)(IPRMN(J),J=1,NPRMN) 

 3425 IF(NPRMN.GT.0)PRINT*,(IPRMN(J),J=1,NPRMN) 

 3426 C CELLS IN LONGITUDINAL SECTION 

 3427 READ(IUNIT,1001) 

 3428 READ(IUNIT,*,ERR=1400)ISLICE 

 3429 IF(JTEST.EQ.1)PRINT*,ISLICE 

 3430 GOTO 1406 

 3431 1400 WRITE(ISCR,1402) 

 3432 1402 FORMAT(1X,'*** ERROR READING ISLICE ***') 

 3433 1410 IF(ISLICE.LE.NDSLC1)GOTO 1406 

 3434 WRITE(ISCR,1404)ISLICE,NDSLC1 

 3435 1404 FORMAT(1X,'*** ERROR: ISLICE=',I2,' GREATER THAN NDSLC1=',I2) 

 3436 STOP 

 3437 1406 CONTINUE 

 3438 IF(ISLICE.EQ.0)GOTO 180 

 3439 DO 170 I=1,ISLICE 

 3440 READ(IUNIT,*)JSLICE(I),(MXNX(J),J=1,JSLICE(I)) 

 3441 IF(JTEST.EQ.1)PRINT*,JSLICE(I),(MXNX(J),J=1,JSLICE(I)) 

 3442 IF(JSLICE(I).LE.NDSLC2)GOTO 155 

 3443 WRITE(ISCR,152)JSLICE(I),NDSLC2 

 3444 152 FORMAT(1X,'*** ERROR: JSLICE=',I2,' GREATER THAT NDSLC2=',I2) 

 3445 STOP 

 3446 155 NTOTAL=0 

 3447 DO 160 J=1,JSLICE(I) 

 3448 MSLICE(J,I)=MXNX(J)/1000 

 3449 NSLICE(J,I)=MXNX(J)-1000*(MXNX(J)/1000) 

 3450 IF(J.GT.1)THEN 

 3451 NDIF=IABS(NSLICE(J,I)-NSLICE(J-1,I)) 

 3452 MDIF=IABS(MSLICE(J,I)-MSLICE(J-1,I)) 

 3453 NTOTAL=NTOTAL+1 

 3454 IF(.NOT.((MDIF.EQ.0.AND.NDIF.GT.0).OR. 

 3455 1 (NDIF.EQ.0.AND.MDIF.GT.0).OR. 

 3456 2 (NDIF.EQ.MDIF)))THEN 

 3457 WRITE(ISCR,157 )I,MDIF,NDIF 

 3458 157 FORMAT(1X,'***ERROR: IN SLICE NO.=',I2,' MDIF=', 

 3459 1 I3,' AND NDIF=',I3) 

 3460 STOP 

 3461 END IF 

 3462 END IF 

 3463 160 CONTINUE 

 3464 166 CONTINUE 

 3465 170 CONTINUE 

 3466 C CELLS FOR LATER GRAPHING 

 3467 180 READ(IUNIT,1001) 

 3468 READ(IUNIT,*,ERR=1411)IGPH,NSTGPH,IGPHOP 

 3469 IF(JTEST.EQ.1)PRINT*,IGPH,NSTGPH,IGPHOP 

 3470 GOTO 1420 

 3471 1411 WRITE(ISCR,1412) 

 3472 1412 FORMAT(5X,'*** ERROR READING IGPH,NGPH ***') 

 3473 1420 IF(IGPH.LE.0)GOTO 191 

 3474 IF(IGPH.LE.NDGPH)GOTO 1430 

 3475 WRITE(ISCR,1424)IGPH,NDGPH 

 3476 1424 FORMAT(1X,'*** ERROR: IGPH=',I2,' GREATER THAN NDGPH=',I2) 

 3477 STOP 

 3478 1430 JGPH=MIN0(IGPH,36) 

 3479 DO 190 I=1,IGPH 

 3480 IF(I.GT.JGPH)READ(IUNIT,*)X 

 3481 IF(I.LE.JGPH)READ(IUNIT,*,ERR=185)LGPH(I),MGPH(I),NGPH(I),ITYP(I) 

 3482 IF(JTEST.EQ.1)PRINT*,LGPH(I),MGPH(I),NGPH(I),ITYP(I) 

 3483 GOTO 190 

 3484 185 WRITE(ISCR,186) 

 3485 186 FORMAT(5X,'*** (RDCON) ERROR READING LGPH, MGPH, ETC ***') 

 3486 190 CONTINUE 

 3487 191 CONTINUE 

 3488 IGPH=JGPH 

 3489 RETURN 

 3490 END 

 3491 C 

 3492 C----------------------------------------------------------------------- 

 3493 C 

 3494 SUBROUTINE RDCON2(JTEST,IVER) 

 3495 

 3496 C JUNE 1994 K. HESS CEOB HP9000 

 3497 C PURPOSE - TO READ IN THE ENVIRONMENTAL DATA AS SEPARATE FILES 

 3498 INCLUDE 'COMM20.FOR' 

 3499 CHARACTER*40 FDATA 

 3500 IUNIT=LUCON 
43

 3501 IU=LUCON 

 3502 C READ RUN START DATE 

 3503 IF(JTEST.EQ.1)WRITE(ISCR,90) 

 3504 90 FORMAT(1X,'TIME VARIABLE INPUTS') 

 3505 READ(IUNIT,1002) 

 3506 1001 FORMAT(1X) 

 3507 1002 FORMAT(/,1X) 

 3508 READ(IUNIT,*,ERR=95 )IYEAR,MONTH,IDAY,IHOUR,IMIN 

 3509 IF(IYEAR.LT.100)IYEAR=IYEAR+1900 

 3510 YEAR=IYEAR 

 3511 YEAR0=YEAR 

 3512 YEAR1=YEAR 

 3513 IF(JTEST.EQ.1)PRINT*,'YEAR=',IYEAR,MONTH,IDAY,IHOUR,IMIN 

 3514 GOTO 98 

 3515 95 WRITE(ISCR,96 ) 

 3516 96 FORMAT(5X,'*** (RDCON) ERROR READING IYEAR, ETC. ***') 

 3517 STOP 

 3518 98 CALL JULIAN(IYEAR,MONTH,IDAY,UT,NDAYMO) 

 3519 UT0=UT+(FLOAT(IHOUR)+FLOAT(IMIN)/60.)/24. 

 3520 IF(JTEST.EQ.1)PRINT*,'UT0=',UT0 

 3521 C 

 3522 C READ TIDAL WATER LEVEL DATA 

 3523 WRITE(ISCR,*)' ' 

 3524 WRITE(ISCR,*)'WATER LEVEL DATA' 

 3525 CALL IRR(IU,ISCR,LUTID,IENDTD,DTID,YTID,NSIGT,NDTID2,TDLEV) 

 3526 C 

 3527 C READ WIND DATA: 

 3528 WRITE(ISCR,*)' ' 

 3529 WRITE(ISCR,*)'WIND DATA' 

 3530 READ(IUNIT,1001) 

 3531 READ(IUNIT,*)NSIGW 

 3532 IENDWN=0 

 3533 IF(NSIGW.EQ.0)THEN 

 3534 WRITE(ISCR,*)' ' 

 3535 WRITE(ISCR,*)' NO INPUT DATA ' 

 3536 IENDWN=1 

 3537 GOTO 300 

 3538 ENDIF 

 3539 READ(IUNIT,100)FDATA 

 3540 100 FORMAT(A40) 

 3541 WRITE(ISCR,130)FDATA,NSIGW,LUWND 

 3542 130 FORMAT(5X,'FILE NAME=',A40,/,5x,'NSIG=',I2,' LUT=',I2) 

 3543 CALL FUOPEN(LUWND,FDATA) 

 3544 DO 220 I=1,2 

 3545 220 CALL RDWIND(I,IEND) 

 3546 IENDWN=IEND 

 3547 300 CONTINUE 

 3548 C 

 3549 C READ IN RIVER FLOWRATE DATA 

 3550 WRITE(ISCR,*)' ' 

 3551 WRITE(ISCR,*)'RIVER FLOWRATE DATA' 

 3552 CALL IRR(IU,ISCR,LURIV,IENDRV,DRIV,YRIV,NSIGR,NDRIV2,QRIV) 

 3553 

 3554 C READ IN OCEANIC SALINITY CONCENTRATION 

 3555 WRITE(ISCR,*)' ' 

 3556 WRITE(ISCR,*)'OCEAN SALINITY DATA' 

 3557 CALL IRR(IU,ISCR,LUSAL,IENDSO,DSAL,YSAL,NSIGS,NDOCN2,SALOCN) 

 3558 

 3559 C READ IN OCEANIC TEMPERATURES 

 3560 WRITE(ISCR,*)' ' 

 3561 WRITE(ISCR,*)'OCEAN TEMPERATURE DATA' 

 3562 CALL IRR(IU,ISCR,LUOCT,IENDTO,DOTP,YOTP,NSIGTO,NDOCN2,TMPOCN) 

 3563 C 

 3564 C READ IN RIVER TEMPERATURES 

 3565 WRITE(ISCR,*)' ' 

 3566 WRITE(ISCR,*)'RIVER TEMPERATURE DATA' 

 3567 CALL IRR(IU,ISCR,LURVT,IENDRT,DRVT,YRVT,NSIGRT,NDRIV2,TRIV) 

 3568 

 3569 C READ IN ADDITIONAL MET DATA 

 3570 WRITE(ISCR,*)' ' 

 3571 WRITE(ISCR,*)'ADDITIONAL MET DATA' 

 3572 CALL IRR(IU,ISCR,LUMET,IENDMT,DMET,YMET,NSIGM,NDMET2,VMET) 

 3573 C 

 3574 C READ IN INITIAL CONDITIONS INDEX AND FILE 

 3575 READ(IUNIT,1001) 

 3576 READ(IUNIT,*)ICS 

 3577 WRITE(ISCR,510)ICS 

 3578 510 FORMAT(/,1X,'INITIALIZATION. ICS=',I2) 

 3579 IF(ICS.EQ.0)GOTO 600 

 3580 READ(IUNIT,100)FINIT 

 3581 WRITE(ISCR,520)FINIT 

 3582 520 FORMAT(1X,' INITIALIZATION FILE NAME=',A40) 

 3583 600 CONTINUE 

 3584 RETURN 

 3585 END 

 3586 

 3587 C------------------------------------------------------------------------ 

 3588 C 

 3589 SUBROUTINE RDCON3(JTEST,IVER) 

 3590 C OCTOBER 1984 K. HESS MEAD VAX 11/70 (REV 8-89) 

 3591 C PURPOSE - TO READ IN THE CONTROL FILE 

 3592 INCLUDE 'COMM20.FOR' 

 3593 DIMENSION MXNX(NPMSIZ) 

 3594 IUNIT=LUCON 

 3595 c READ OUTPUT FILE NAMES 

 3596 READ(IUNIT,1001) 

 3597 1001 FORMAT(1X) 

 3598 READ(IUNIT,440)FPRINT 

 3599 READ(IUNIT,440)FGRAPH 

 3600 READ(IUNIT,440)FMED 

 3601 WRITE(6,*)'OUTPUT FILE NAMES' 

 3602 WRITE( 6,440)FPRINT 

 3603 WRITE( 6,440)FGRAPH 

 3604 WRITE( 6,440)FMED 

 3605 440 FORMAT(10X,A40) 

 3606 C READ END OF DATA STATEMENT 

 3607 READ(IUNIT,1001) 

 3608 IF(JTEST.EQ.1)WRITE(ISCR,1303) 

 3609 1303 FORMAT(1X,'END OF CONTROL FILE READ') 

 3610 RETURN 

 3611 END 

 3612 C 

 3613 C------------------------------------------------------------------------ 

 3614 C 

 3615 SUBROUTINE JULIAN(IY,MO,IDAY,UT) 

 3616 C JAN 1995 HESS CEOB SGI 4D 

 3617 c purpose - to convert year, month, etc to a Julian date and 

 3618 c number of hours from start of year 

 3619 C NOTE: UT IS NOS CONVENTION, SO NOON ON JANUARY 1 

 3620 C IS UT=1.50 

 3621 DIMENSION NMON(12,2) 

 3622 DATA NMON/0,31,59,90,120,151,181,212,243,273,304,334, 

 3623 1 0,31,60,91,121,152,182,213,244,274,305,335/ 

 3624 C CONVERT TO 4-DIGIT IF NOT 

 3625 IYEAR=IYR4(IY) 

 3626 c look for leap year 

 3627 L=1 

 3628 IF(MOD(IYEAR,4).EQ.0.AND.(.NOT.(MOD(IYEAR,100).EQ.0.AND. 

 3629 1 MOD(IYEAR,400).NE.0)))L=2 

 3630 UT=NMON(MO,L)+IDAY 

 3631 RETURN 

 3632 END 

 3633 C----------------------------------------------------------------------- 

 3634 FUNCTION IYR4(IY) 

 3635 IYR4=IY 

 3636 IF(IY.LT.100.AND.IY.GT.50)IYR4=IY+1900 

 3637 IF(IY.LT.50)IYR4=IY+2000 

 3638 RETURN 

 3639 END 

 3640 C----------------------------------------------------------------------- 

 3641 

 3642 SUBROUTINE FFOPEN(IUNIT,FNAME) 

 3643 C PURPOSE - TO OPEN A FORMATTED FILE 

 3644 CHARACTER FNAME*(*) 

 3645 100 OPEN(UNIT=IUNIT,FILE=FNAME,FORM='FORMATTED',STATUS='UNKNOWN', 

 3646 1 IOSTAT=IER,ERR=110) 

 3647 GOTO 140 

 3648 110 WRITE(6,120)FNAME 

 3649 120 FORMAT(1X,'***ERROR IN FILE : ',A50,/,x,'***RUN TERMINATED') 

 3650 STOP 

 3651 140 RETURN 

 3652 END 

 3653 

 3654 C----------------------------------------------------------------------- 

 3655 

 3656 SUBROUTINE FUOPEN(IUNIT,FNAME) 

 3657 C PURPOSE - TO OPEN A FORMATTED FILE 

 3658 CHARACTER FNAME*(*) 

 3659 100 OPEN(UNIT=IUNIT,FILE=FNAME,FORM='UNFORMATTED',STATUS='UNKNOWN', 

 3660 1 IOSTAT=IER,ERR=110) 

 3661 GOTO 140 

 3662 110 WRITE(6,120)FNAME 

 3663 120 FORMAT(1X,'***ERROR IN FILE : ',A50,/,x,'***RUN TERMINATED') 

 3664 STOP 

 3665 140 RETURN 

 3666 END 

 3667 C 

 3668 C----------------------------------------------------------------------- 

 3669 C 

 3670 SUBROUTINE RDGEO(IGEO) 

 3671 C OCTOBER 1984 K. W. HESS ASIC/MEAD VAX 11/750 

 3672 C PURPOSE - TO READ IN PARAMETERS, PLUS IFIELD, DEPTH, AND 

 3673 C FLAG DATA. 

 3674 C VARIABLES - 

 3675 C IAH = INDEX TO READ HORIZ. EDDY VISCOSITY: 0=NO 

 3676 C IGRID = INDEX TO READ STRETCHED GRIDS:0=NO, 1=READ XE,YE 

 3677 C 2=READ NSEGX, ETC. 

 3678 C NUMBXY = NUMBER OF CHANNEL GRIDS 

 3679 C NO,NR = NUMBER OF OCEAN, RIVER BOUNDARY CELLS AS 

 3680 C DETERMINED BY IFIELD 

 3681 C NO1,NRV1 = NUMBER OF OCEAN, RIVER BOUNDARY CELLS AS 

 3682 C DETERMINED BY NUMOBC, NUMRIV 

 3683 C XC(,) = DISTANCE FROM ORIGIN TO GRID CENTER 

 3684 C XL(,) = DISTANCE TO LOWER SIDE OF GRID M 

 3685 INCLUDE 'COMM20.FOR' 

 3686 DIMENSION NUM(NPMSIZ),XL(NPMSIZ),YL(NPMSIZ) 

 3687 CHARACTER*10 FORM,GTITLE(6) 

 3688 DATA NDX,NDY/MSIZE,NSIZE/ 

 3689 C THIS IS VERSION 2 (8-89) 

 3690 JVER=2 

 3691 C READ IN MECCA FILE HEADER BLOCK 

 3692 200 READ(IGEO,202)(GTITLE(N),N=1,6) 

 3693 202 FORMAT(1X,6A10) 

 3694 READ(IGEO,*)J,ITEST 

 3695 IF(ITEST.EQ.1)WRITE(ISCR,2200)(GTITLE(N),N=1,6),J 

 3696 2200 FORMAT(/,5X,'GEOGRAPHY FILE',/,1X,'TITLE=',6A10,' J=',I3) 

 3697 IF(J.NE.JVER)THEN 

 3698 WRITE(ISCR,204)J,JVER 

 3699 204 FORMAT(1X,'INPUT FILE IS VERSION=',I2,' RDGEO IS VERSION=',I2, 

 3700 1 ' RUN IS STOPPED') 

 3701 STOP 

 3702 END IF 

 3703 C 

 3704 C GRID PARAMETERS 

 3705 READ(IGEO,1002) 

 3706 1001 FORMAT(1X) 

 3707 1002 FORMAT(/,1X) 

 3708 READ(IGEO,*,ERR=222)NMAX,MMAX,DL 

 3709 IF(ITEST.EQ.1)WRITE(ISCR,2220)NMAX,MMAX,DL 

 3710 2220 FORMAT(1X,'NMAX,MMAX,DL=',2I5,E10.5) 

 3711 GOTO 226 

 3712 222 WRITE(ISCR,224) 

 3713 224 FORMAT(1X,'*** (RDGEO) ERROR READING NMAX,MMAX,DL ***') 

 3714 226 IF(MMAX.LE.NDX.AND.NMAX.LE.NDY)GOTO 228 

 3715 WRITE(ISCR,227)NMAX,NDY,MMAX,NDX 

 3716 227 FORMAT(1X,'*** ERROR: NMAX=',I3,' GT NDY=',I3,' OR MMAX=',I3, 

 3717 1 ' GT NDX=',I3) 

 3718 STOP 

 3719 228 CONTINUE 

 3720 READ(IGEO,1001) 

 3721 READ(IGEO,*,ERR=232)NCOR,MCOR,BSNLAT,BSNLON,BSNANG 

 3722 IF(ITEST.EQ.1)WRITE(ISCR,2260)NCOR,MCOR,BSNLAT,BSNLON,BSNANG 

 3723 2260 FORMAT(1X,'NCOR=',2I5,3F10.3) 

 3724 GOTO 234 

 3725 232 WRITE(ISCR,233) 

 3726 233 FORMAT(1X,'**** RDGEO. PROBLEM READING LINE NCOR,MCOR, ETC ***') 

 3727 RETURN 

 3728 

 3729 C OCEAN BOUNDARY CONDITIONS 

 3730 234 READ(IGEO,1001) 

 3731 READ(IGEO,*)NUMOBC 

 3732 NUMBC=NUMOBC 

 3733 IF(ITEST.EQ.1)WRITE(ISCR,2340)NUMOBC 

 3734 2340 FORMAT(1X,'NUMOBC=',I3) 

 3735 237 IF(NUMOBC.LE.0)GOTO 242 

 3736 DO 240 I=1,NUMOBC 

 3737 READ(IGEO,*)MB1(I),MB2(I),NB1(I),NB2(I),ITPO(I),JTPO(I),ISET1(I), 

 3738 1 ISET2(I) 

 3739 c READ(IGEO,*)MB1(I),MB2(I),NB1(I),NB2(I),ITPO(I),ISET1(I),ISET2(I) 

 3740 IF(ITEST.EQ.1)WRITE(ISCR,2360)MB1(I),MB2(I),NB1(I),NB2(I),ISET1(I) 

 3741 1 ,ISET2(I) 

 3742 2360 FORMAT(1X,'MB1=',6I5) 

 3743 IF(.NOT.(MB1(I).LE.MB2(I).AND.NB1(I).LE.NB2(I)))THEN 

 3744 WRITE(ISCR,238)I,MB1(I),MB2(I),NB1(I),NB2(I) 

 3745 238 FORMAT(/,1X,'*** ERROR *** AT OCEAN BOUNDARY # ',I2,' MB1=',I3, 

 3746 1 ' IS GT MB2=',I3,/,' OR NB1=',I3,' IS GT NB2=',I3) 

 3747 STOP 

 3748 END IF 

 3749 IF(.NOT.(MB1(I).EQ.MB2(I).OR.NB1(I).EQ.NB2(I)))THEN 

 3750 WRITE(ISCR,2238)I,MB1(I),MB2(I),NB1(I),NB2(I) 

 3751 2238 FORMAT(/,1X,'*** ERROR *** AT OCEAN BOUNDARY # ',I2,' MB1=',I3, 

 3752 1 ' IS .NE. MB2=',I3,/,' OR NB1=',I3,' IS .NE. NB2=',I3) 
44

 3753 STOP 

 3754 END IF 

 3755 240 CONTINUE 

 3756 C 

 3757 C READ IN RIVER BOUNDARIES 

 3758 242 READ(IGEO,1001) 

 3759 READ(IGEO,*)NUMRIV 

 3760 IF(ITEST.EQ.1)WRITE(ISCR,2450)NUMRIV 

 3761 2450 FORMAT(1X,'NUMRIV=',I5) 

 3762 IF(NUMRIV.LE.0)GOTO 248 

 3763 DO 246 I=1,NUMRIV 

 3764 READ(IGEO,*)MR1(I),MR2(I),NR1(I),NR2(I),ITPR(I),JTPR(I),ISETR(I) 

 3765 IF(ITEST.EQ.1)WRITE(ISCR,2460)MR1(I),MR2(I),NR1(I),NR2(I),ITPR(I) 

 3766 1 ,JTPR(I),ISETR(I) 

 3767 2460 FORMAT(1X,'MR1=',7I5) 

 3768 JTPR(I)=MAX0(1,MIN0(2,JTPR(I))) 

 3769 IF(.NOT.(MR1(I).LE.MR2(I).AND.NR1(I).LE.NR2(I)))THEN 

 3770 WRITE(ISCR,1238)I,MR1(I),MR2(I),NR1(I),NR2(I) 

 3771 1238 FORMAT(/,1X,'*** ERROR *** AT RIVER BOUNDARY # ',I2,' MB1=',I3, 

 3772 1 ' IS GT MB2=',I3,/,' OR NB1=',I3,' IS GT NB2=',I3) 

 3773 STOP 

 3774 END IF 

 3775 IF(.NOT.(MR1(I).EQ.MR2(I).OR.NR1(I).EQ.NR2(I)))THEN 

 3776 WRITE(ISCR,1239)I,MR1(I),MR2(I),NR1(I),NR2(I) 

 3777 1239 FORMAT(/,1X,'*** ERROR *** AT RIVER BOUNDARY # ',I2,' MB1=',I3, 

 3778 1 ' IS .NE. MB2=',I3,/,' OR NB1=',I3,' IS .NE. NB2=',I3) 

 3779 STOP 

 3780 END IF 

 3781 246 CONTINUE 

 3782 C 

 3783 C READ THE CELL STATUS FIELD (IFIELD) 

 3784 248 READ(IGEO,1001) 

 3785 READ(IGEO,2490,ERR=249)FORM 

 3786 2490 FORMAT(1X,A10) 

 3787 IF(ITEST.EQ.1)WRITE(ISCR,2491)FORM 

 3788 2491 FORMAT(1X,'CELL STATUS: FORM=',A10) 

 3789 GOTO 2494 

 3790 249 WRITE(ISCR,2492) 

 3791 2492 FORMAT(1X,'*** ERROR READING FORM ***') 

 3792 2494 READ(IGEO,*)NPERL,KOCNBC 

 3793 IF(ITEST.EQ.1)WRITE(ISCR,2496)NPERL,KOCNBC 

 3794 2496 FORMAT(1X,'NPERL=',2I5) 

 3795 IF(KOCNBC.GE.4.AND.KOCNBC.LE.8)GOTO 2502 

 3796 WRITE(ISCR,2501)KOCNBC 

 3797 2501 FORMAT(1X,'*** ERROR: KOCNBC=',I3,' NOT BETWEEN 4 AND 8') 

 3798 STOP 

 3799 2502 IF(ITEST.EQ.1)WRITE(ISCR,*)' IFIELD' 

 3800 KMAX=1+(NMAX-1)/NPERL 

 3801 DO 250 K=1,KMAX 

 3802 N1=1+(K-1)*NPERL 

 3803 N2=MIN0(N1+NPERL-1,NMAX) 

 3804 DO 250 M=1,MMAX 

 3805 READ(IGEO,FORM)(IFIELD(N,M),N=N1,N2) 

 3806 IF(ITEST.EQ.1)WRITE(ISCR,2497)(IFIELD(N,M),N=N1,N2) 

 3807 2497 FORMAT(40I2) 

 3808 250 CONTINUE 

 3809 C 

 3810 C READ THE DEPTHS 

 3811 READ(IGEO,1001) 

 3812 READ(IGEO,2490)FORM 

 3813 IF(ITEST.EQ.1)WRITE(ISCR,2642)FORM 

 3814 2642 FORMAT(1X,'DEPTHS: FORM=',A10) 

 3815 READ(IGEO,*,ERR=264)NCOL2,HMSL,CON2M 

 3816 IF(ITEST.EQ.1)WRITE(ISCR,2643)NCOL2,HMSL,CON2M 

 3817 2643 FORMAT(1X,'NCOL2=',I5,2F10.3) 

 3818 GOTO 266 

 3819 264 WRITE(ISCR,265) 

 3820 265 FORMAT(1X,'*** ERROR READING NCOL2,HMSL,CON2M ***') 

 3821 

 3822 266 NSWEEP=1+(NMAX-1)/NCOL2 

 3823 DO 285 NN=1,NSWEEP 

 3824 N1=1+NCOL2*(NN-1) 

 3825 N2=MIN0(NMAX,N1+NCOL2-1) 

 3826 DO 280 M=1,MMAX 

 3827 READ(IGEO,FORM)(NUM(N),N=N1,N2) 

 3828 IF(ITEST.EQ.1)WRITE(ISCR,FORM)(NUM(N),N=N1,N2) 

 3829 C CONVERT DEPTHS TO METERS AND ADD HMSL 

 3830 DO 275 N=N1,N2 

 3831 D(N,M)=0.0 

 3832 275 IF(IFIELD(N,M).GT.0)D(N,M)=FLOAT(NUM(N))*CON2M+HMSL 

 3833 280 CONTINUE 

 3834 285 CONTINUE 

 3835 C 

 3836 C SET GRID WIDTHS AND AREA 

 3837 READ(IGEO,1001) 

 3838 READ(IGEO,*,ERR=301)NUMBXY 

 3839 IF(ITEST.EQ.1)WRITE(ISCR,3301)NUMBXY 

 3840 3301 FORMAT(1X,'WIDTH DATA: NUMBXY=',I5) 

 3841 GOTO 305 

 3842 301 WRITE(ISCR,302) 

 3843 302 FORMAT(1X,'*** ERROR READING NUMBXY ***') 

 3844 305 CONTINUE 

 3845 C GRID X,Y COORDINATES 

 3846 DO 311 I=1,NPMSIZ 

 3847 XL(I)=I-1 

 3848 311 YL(I)=I-1 

 3849 DO 320 M=1,MMAX 

 3850 DO 320 N=1,NMAX 

 3851 BX(N,M)=1.0 

 3852 BY(N,M)=1.0 

 3853 AREA(N,M)=(XL(M+1)-XL(M))*(YL(N+1)-YL(N)) 

 3854 IF(IFIELD(N,M)/10.EQ.1)AREA(N,M)=0.5*AREA(N,M) 

 3855 320 CONTINUE 

 3856 C READ THRU THE CHANNEL WIDTHS 

 3857 IF(NUMBXY.LE.0)GOTO 350 

 3858 DO 340 J=1,NUMBXY 

 3859 READ(IGEO,*)M,N,BX(N,M),BY(N,M),F1 

 3860 IF(ITEST.EQ.1)WRITE(ISCR,3111)J,M,N,BX(N,M),BY(N,M),F1 

 3861 3111 FORMAT(1X,'J=',I4,' M,N=',2I5,3F10.4) 

 3862 AREA(N,M)=AREA(N,M)*F1 

 3863 340 CONTINUE 

 3864 350 CONTINUE 

 3865 C 

 3866 IF(ITEST.EQ.1)WRITE(ISCR,3391) 

 3867 3391 FORMAT(1X,'END OF GEOGRAPHY DATA FILE') 

 3868 C CHECK BOUNDARIES 

 3869 400 CALL CHECKS 

 3870 RETURN 

 3871 END 

 3872 C 

 3873 C----------------------------------------------------------------------- 

 3874 C 

 3875 SUBROUTINE CHECKS 

 3876 C OCTOBER 1986 HESS MEAD VAX 780 

 3877 C PURPOSE - TO CHECK FOR CONSISTANCY BETWEEN RIVER AND OCEAN 

 3878 C BOUNDARIES AND THE IFIELD SPECIFICATION 

 3879 C 

 3880 INCLUDE 'COMM20.FOR' 

 3881 DIMENSION IFLOWS(6) 

 3882 DATA NDBNDS/NM2SIZ/ 

 3883 C CHECK FOR TIMESTEP SIZE 

 3884 PERHR=3600./DTI 

 3885 IF(ABS(3600.-IFIX(PERHR)*DTI).GT.0.001)THEN 

 3886 WRITE(ISCR,100)DTI,PERHR 

 3887 100 FORMAT(1X,'***ERROR: TIMESTEP (SEC) = ',F8.3,', BUT NUMBER PER', 

 3888 1 ' HOUR =',F10.4,' IS NOT AN INTEGER') 

 3889 STOP 

 3890 END IF 

 3891 C CHECK FOR NO DEPTH 

 3892 NCELL=0 

 3893 NBAD=0 

 3894 DO 280 M=1,MMAX 

 3895 DO 275 N=1,NMAX 

 3896 IF(IFIELD(N,M).LT.10)GOTO 275 

 3897 NCELL=NCELL+1 

 3898 IF(D(N,M).GT.0.0)GOTO 275 

 3899 NBAD=NBAD+1 

 3900 WRITE(ISCR,272)M,N,D(N,M) 

 3901 272 FORMAT(1X,'*** (CHECKS) BAD DEPTH VALUE AT M=',I3,' N=',I3, 

 3902 1 ' D=',F8.2) 

 3903 275 CONTINUE 

 3904 280 CONTINUE 

 3905 IF(NBAD.GT.0)THEN 

 3906 WRITE(ISCR,285) 

 3907 285 FORMAT(/,1X,'*** BAD DEPTH DATA. RUN ENDED ***') 

 3908 STOP 

 3909 END IF 

 3910 C CHECK OCEAN FLAGS WITH MESH CELLS 

 3911 NO1=0 

 3912 NBAD=0 

 3913 IF(NUMOBC.LE.0)GOTO 320 

 3914 DO 310 I=1,NUMOBC 

 3915 DO 310 M=MB1(I),MB2(I) 

 3916 DO 310 N=NB1(I),NB2(I) 

 3917 NO1=NO1+1 

 3918 IF(IFIELD(N,M)/10.NE.KOCNBC)THEN 

 3919 WRITE(ISCR,305)KOCNBC,N,M 

 3920 305 FORMAT(1X,'*** IFIELD/10 SHOULD BE ',I1,' AT N=',I3,' M=',I3) 

 3921 NBAD=NBAD+1 

 3922 END IF 

 3923 310 CONTINUE 

 3924 C CHECK RIVER FLAGS WITH MESH CELLS 

 3925 320 IF(NUMRIV.LE.0)GOTO 350 

 3926 DO 330 I=1,NUMRIV 

 3927 DO 330 M=MR1(I),MR2(I) 

 3928 DO 330 N=NR1(I),NR2(I) 

 3929 NO1=NO1+1 

 3930 C MAKE SURE IFIELD/10 EQUALS KOCNBC+1 

 3931 IF(IFIELD(N,M)/10.NE.KOCNBC+1)THEN 

 3932 WRITE(ISCR,321)N,M 

 3933 321 FORMAT(1X,'*** IFIELD SHOULD BE 10*(KOCNBC+1) AT N=',I3,' M=',I3) 

 3934 NBAD=NBAD+1 

 3935 END IF 

 3936 330 CONTINUE 

 3937 350 CONTINUE 

 3938 C CHECK FOR CELLS WITH WRONG INDEX 

 3939 IF(NBAD.GT.0)THEN 

 3940 WRITE(ISCR,353)NBAD 

 3941 353 FORMAT(1X,'***ERROR: NUMBER OF CELLS ON BOUND BAD=',I4) 

 3942 STOP 

 3943 END IF 

 3944 C CHECK FOR TOTAL NUMBER OF BOUNDARY CELLS 

 3945 IF(NO1.LE.NDBNDS)GOTO 356 

 3946 WRITE(ISCR,354)NO1,NDBNDS 

 3947 354 FORMAT(1X,'***ERROR: BOUNDARY CELLS=',I4,' GT NDBNDS=',I3) 

 3948 STOP 

 3949 356 CONTINUE 

 3950 C CHECK IFIELD SPECIFICATIONS AGAINST BOUNDARY FLAGS 

 3951 NBAD=0 

 3952 DO 450 M=1,MMAX 

 3953 DO 450 N=1,NMAX 

 3954 IF(IFIELD(N,M)/10.EQ.KOCNBC)GOTO 360 

 3955 IF(IFIELD(N,M)/10.EQ.KOCNBC+1)GOTO 400 

 3956 GOTO 450 

 3957 C OCEAN CHECK 

 3958 360 IF(NUMOBC.LE.0)GOTO 390 

 3959 DO 380 I=1,NUMOBC 

 3960 M1=MB1(I) 

 3961 M2=MB2(I) 

 3962 N1=NB1(I) 

 3963 N2=NB2(I) 

 3964 DO 380 L=M1,M2 

 3965 DO 380 K=N1,N2 

 3966 380 IF(L.EQ.M.AND.K.EQ.N) GOTO 450 

 3967 390 WRITE(ISCR,395)N,M 

 3968 395 FORMAT(/,1X,'*** WARNING. CELL N=',I3,', M=',I3,' IS NOT SET IN', 

 3969 1 ' ANY OCEANIC BOUNDARY FLAG') 

 3970 NBAD=NBAD+1 

 3971 GOTO 450 

 3972 C RIVER CHECK 

 3973 400 IF(NUMRIV.LE.0)GOTO 430 

 3974 DO 420 I=1,NUMRIV 

 3975 DO 420 K=NR1(I),NR2(I) 

 3976 DO 420 L=MR1(I),MR2(I) 

 3977 420 IF(K.EQ.N.AND.L.EQ.M)GOTO 450 

 3978 430 WRITE(ISCR,440)N,M 

 3979 440 FORMAT(/,1X,'*** WARNING. CELL AT N=',I3,', M=',I3,' IS NOT ', 

 3980 1 'SET IN ANY RIVER BOUNDARY FLAG') 

 3981 NBAD=NBAD+1 

 3982 450 CONTINUE 

 3983 C CHECK FOR TOTAL BAD CELLS 

 3984 IF(NBAD.GT.0)THEN 

 3985 WRITE(ISCR,455)NBAD 

 3986 455 FORMAT(1X,'*** ERROR: CELLS IN GRID THAT ARE NOT IN A FLAG=',I4) 

 3987 STOP 

 3988 END IF 

 3989 C 

 3990 C CHECK TRIANGULAR CELLS FOR LAND/BARRIERS ON TWO ADJACENT SIDES 

 3991 NBAD=0 

 3992 DO 500 M=1,MMAX 

 3993 DO 500 N=1,NMAX 

 3994 IF(IFIELD(N,M)/10.NE.1)GOTO 500 

 3995 C X FLOW 

 3996 IXM=1 

 3997 IF(M.EQ.1)THEN 

 3998 IXM=0 

 3999 ELSE 

 4000 II=IFIELD(N,M-1) 

 4001 IF(II.LT.10.OR.MOD(II,10).EQ.1.OR.MOD(II,10).EQ.3)IXM=0 

 4002 END IF 

 4003 IXP=1 

 4004 II=IFIELD(N,M) 
45

 4005 IF(IFIELD(N,M+1).LT.10.OR.MOD(II,10).EQ.1.OR.MOD(II,10).EQ.3)IXP=0 

 4006 C Y FLOW 

 4007 IYM=1 

 4008 IF(N.EQ.1)THEN 

 4009 IYM=0 

 4010 ELSE 

 4011 II=IFIELD(N-1,M) 

 4012 IF(II.LT.10.OR.MOD(II,10).EQ.2.OR.MOD(II,10).EQ.3)IYM=0 

 4013 END IF 

 4014 IYP=1 

 4015 II=IFIELD(N,M) 

 4016 IF(IFIELD(N+1,M).LT.10.OR.MOD(II,10).EQ.2.OR.MOD(II,10).EQ.3)IYP=0 

 4017 C CHECK FOR ADJACENTS 

 4018 IFLOWS(1)=IXP 

 4019 IFLOWS(2)=IYP 

 4020 IFLOWS(3)=IXM 

 4021 IFLOWS(4)=IYM 

 4022 IFLOWS(5)=IFLOWS(1) 

 4023 IFLOWS(6)=IFLOWS(2) 

 4024 DO 460 I=1,4 

 4025 IF(IFLOWS(I)+IFLOWS(I+1).EQ.0)GOTO 480 

 4026 460 CONTINUE 

 4027 WRITE(ISCR,470)N,M,IXP,IYP,IXM,IYM 

 4028 470 FORMAT(/,1X,'*** WARNING. TRIANGULAR CELL AT N=',I3,', M=',I3, 

 4029 1 ' HAS INCORRECT SIDES',/,1X,'IXP,IYP,IXM,IYM=',4I4) 

 4030 NBAD=NBAD+1 

 4031 480 CONTINUE 

 4032 C CHECK FOR TOTAL TRIANGULAR CELLS NOT WELL DEFINED 

 4033 IF(NBAD.GT.0)THEN 

 4034 WRITE(ISCR,495)NBAD 

 4035 495 FORMAT(1X,'***ERROR: TRIANGULAR CELLS NOT WELL DEFINED=',I4) 

 4036 STOP 

 4037 END IF 

 4038 500 CONTINUE 

 4039 c 

 4040 c CHECK FOR CORRESPONDANCE BETWEEN (1) BOUNDARIES AND (2) INPUT SIG

 4041 WRITE(ISCR,*)' ' 

 4042 WRITE(ISCR,*)'CHECK BOUNDARIES AND DATA' 

 4043 NBAD=0 

 4044 c ocean boundaries 

 4045 IF(NUMOBC.GT.0)THEN 

 4046 IF(NSIGTD.EQ.0)THEN 

 4047 WRITE(ISCR,*)'**NO WATER LEVEL SIGNALS AT OCEAN BOUNDARY**' 

 4048 NBAD=1 

 4049 ENDIF 

 4050 IF((KONCEN.EQ.1.OR.KONCEN.EQ.3).AND.NSIGS.EQ.0)THEN 

 4051 WRITE(ISCR,*)'**NO SALINITY SIGNALS AT OCEAN BOUNDARY**' 

 4052 NBAD=1 

 4053 ENDIF 

 4054 IF((KONCEN.EQ.2.OR.KONCEN.EQ.3).AND.NSIGTO.EQ.0)THEN 

 4055 WRITE(ISCR,*)'**NO TEMPERATURE SIGNALS AT OCEAN BOUNDARY**' 

 4056 NBAD=1 

 4057 ENDIF 

 4058 ENDIF 

 4059 c river boundaries 

 4060 IF(NUMRIV.GT.0)THEN 

 4061 IF(NSIGR.EQ.0)THEN 

 4062 WRITE(ISCR,*)'**NO FLOW RATE DATA AT RIVER BOUNDARY**' 

 4063 NBAD=1 

 4064 ENDIF 

 4065 IF((KONCEN.EQ.2.OR.KONCEN.EQ.3).AND.NSIGRT.EQ.0)THEN 

 4066 WRITE(ISCR,*)'**NO TEMPERATURE SIGNALS AT RIVER BOUNDARY**' 

 4067 NBAD=1 

 4068 ENDIF 

 4069 ENDIF 

 4070 c air-sea boundaries 

 4071 IF((KONCEN.EQ.2.OR.KONCEN.EQ.3).AND.NSIGW.EQ.0)THEN 

 4072 WRITE(ISCR,*)'**NO WIND DATA AT AIR-SEA BOUNDARY**' 

 4073 NBAD=1 

 4074 ENDIF 

 4075 IF((KONCEN.EQ.2.OR.KONCEN.EQ.3).AND.NSIGM.EQ.0)THEN 

 4076 WRITE(ISCR,*)'**NO ADDITIONAL MET DATA AT AIR-SEA BOUNDARY**' 

 4077 NBAD=1 

 4078 ENDIF 

 4079 IF(NBAD.EQ.1)STOP 

 4080 

 4081 RETURN 

 4082 END 

 4083 C 

 4084 C---------------------------------------------------------------- 

 4085 C 

 4086 SUBROUTINE RDICS 

 4087 C FEBRUARY 1997 K. W. HESS IRIS 

 4088 C PURPOSE - TO READ IN THE INITIAL CONDITIONS 

 4089 INCLUDE 'COMM20.FOR' 

 4090 C READ THE INDICES 

 4091 LUICS=LUCON 

 4092 WRITE(ISCR,100)LUICS 

 4093 100 FORMAT(X,'NOW READING THE ICS FILE ON UNIT=',I2) 

 4094 CALL FUOPEN(LUICS,FINIT) 

 4095 READ(LUICS)NIX,MIX,LBOT1,NSTET,UT01,YEAR01,K 

 4096 WRITE(ISCR,110)UT1,YEAR1,NSTET,K 

 4097 110 FORMAT(5X,'UT1=',F10.4,' YEAR1=',F6.1,' NSTET=',I6,' K=',I2) 

 4098 READ(LUICS)SE,UE,VE,SOLD,UHOLD,VHOLD,AH,AV,PHI,TBX,TBY, 

 4099 1 U,V,W,THETA1,THETA2,THETA3 

 4100 IF(K.GE.10)READ(LUICS)AH3,WX,WY,TSX,TSY 

 4101 IF(MOD(K,10).GT.0)READ(LUICS)S,T,DV,RI,NSTINF 

 4102 C RESET SECONDARY VARIABLES 

 4103 YEAR1=YEAR01 

 4104 UT1=UT01 

 4105 DO 120 M=1,MMAX 

 4106 MP=MIN0(M+1,MMAX) 

 4107 DO 120 N=1,NMAX 

 4108 IF(IFIELD(N,M).LT.10)GOTO 120 

 4109 NP=MIN0(N+1,NMAX) 

 4110 UH(N,M)=UE(N,M)*.5*(D(N,M)+SE(N,M)+D(N,MP)+SE(N,MP)+E)*BX(N,M) 

 4111 VH(N,M)=VE(N,M)*.5*(D(N,M)+SE(N,M)+D(NP,M)+SE(NP,M)+E)*BY(N,M) 

 4112 AHC(N,M)=.25*(AH(N,M)+AH(N,MP)+AH(NP,M)+AH(NP,MP)) 

 4113 120 CONTINUE 

 4114 c if no AH3 

 4115 IF(INTER.GT.0.AND.KONC.LT.10)THEN 

 4116 DO 140 M=1,MMAX 

 4117 DO 140 N=1,NMAX 

 4118 DO 140 L=1,LBOT 

 4119 140 AH3(L,N,M)=AH(N,M) 

 4120 ENDIF 

 4121 WRITE(ISCR,*)'COMPLETE RDICS' 

 4122 CLOSE (LUICS) 

 4123 RETURN 

 4124 END 

 4125 C 

 4126 C--------------------------------------------------------------- 

 4127 C 

 4128 SUBROUTINE ZEROS 

 4129 C APRIL 1988 K. W. HESS 

 4130 C PURPOSE - INITIALIZE THE PARAMETERS TO ZERO BEFORE 

 4131 C INPUT FILES HAVE BEEN READ IN. 

 4132 C VARIABLES - 

 4133 INCLUDE 'COMM20.FOR' 

 4134 C INITIALIZE VISCOSITIES AND DEPTHS 

 4135 LBOT=LSIZE 

 4136 DO 130 M=1,MSIZE 

 4137 DO 130 N=1,NSIZE 

 4138 AREA(N,M)=0.0 

 4139 TSX(N,M)=0.0 

 4140 TSY(N,M)=0.0 

 4141 WX(N,M)=0.0 

 4142 WY(N,M)=0.0 

 4143 TBX(N,M)=0.0 

 4144 TBY(N,M)=0.0 

 4145 UH(N,M)=0.0 

 4146 VH(N,M)=0.0 

 4147 SE(N,M)=0.0 

 4148 SEP(N,M)=0.0 

 4149 SEPP(N,M)=0.0 

 4150 UHP(N,M)=0.0 

 4151 VHP(N,M)=0.0 

 4152 SOLD(N,M)=0.0 

 4153 UHOLD(N,M)=0.0 

 4154 VHOLD(N,M)=0.0 

 4155 THETA1(N,M)=0.0 

 4156 THETA2(N,M)=0.0 

 4157 THETA3(N,M)=0.0 

 4158 UE(N,M)=0.0 

 4159 VE(N,M)=0.0 

 4160 AH(N,M)=00 

 4161 AHC(N,M)=00 

 4162 FEDGE(N,M)=1.0 

 4163 PHI(N,M)=0.0 

 4164 MFLUX(N,M)=0.0 

 4165 NFLUX(N,M)=0.0 

 4166 C LOOP OVER LEVELS 

 4167 DO 120 L=1,LSIZE 

 4168 U(L,N,M)=0.0 

 4169 V(L,N,M)=0.0 

 4170 W(L,N,M)=0.0 

 4171 AH3(L,N,m)=0. 

 4172 S(L,N,M)=0.0 

 4173 T(L,N,M)=0.0 

 4174 RI(L,N,M)=0.0 

 4175 DV(L,N,M)=00 

 4176 120 AV(L,N,M)=00 

 4177 130 CONTINUE 

 4178 

 4179 DO 135 L=1,LSIZE 

 4180 DO 135 I=1,NM2SIZ 

 4181 135 NSTINF(L,I)=0 

 4182 C SET HEAT FLUXES 

 4183 QI=0.0 

 4184 QA=0.0 

 4185 QB=0.0 

 4186 QS=0.0 

 4187 QE=0.0 

 4188 RETURN 

 4189 END 

 4190 c----------------------------------------------------------------------- 

 4191 SUBROUTINE YTIME8(YT8,UT,YEAR) 

 4192 c create a date from year and Julian day 

 4193 REAL*8 YT8,UT8,DAYS 

 4194 c look for leap year 

 4195 IYEAR=YEAR 

 4196 DAYS=365. 

 4197 IF(MOD(IYEAR,4).EQ.0.AND.(.NOT.(MOD(IYEAR,100).EQ.0.AND. 

 4198 1 MOD(IYEAR,400).NE.0)))DAYS=366. 

 4199 UT8=UT 

 4200 YT8=FLOAT(IYEAR-1900)+(UT8-1.)/DAYS 

 4201 RETURN 

 4202 END 

 4203 C 

 4204 C----------------------------------------------------------------------- 

 4205 C 

 4206 SUBROUTINE RR(YT,ISCR,LUT,IEND,DD,YD,NSIG,NN,VALS,FINAL) 

 4207 c generic read for input data records 

 4208 DIMENSION DD(2),YD(2),VALS(2,NN),FINAL(NN) 

 4209 REAL*8 YT,YT1,YT2 

 4210 DO 90 N=1,NN 

 4211 90 FINAL(N)=0.0 

 4212 IF(NSIG.EQ.0.OR.IEND.EQ.1)RETURN 

 4213 CALL YTIME8(YT1,DD(1),YD(1)) 

 4214 CALL YTIME8(YT2,DD(2),YD(2)) 

 4215 IF(YT.LT.YT1)THEN 

 4216 WRITE(ISCR,95)LUT,YT,YT1 

 4217 95 FORMAT(1X,'** EARLIER THAN FIRST DATA TIME ON UNIT=',I2,/, 

 4218 1 'YT=',F12.8,' YT1=',F12.8,' **') 

 4219 RETURN 

 4220 ENDIF 

 4221 100 IF(YT.GT.YT2)THEN 

 4222 DO 120 N=1,NSIG 

 4223 120 VALS(1,N)=VALS(2,N) 

 4224 DD(1)=DD(2) 

 4225 YD(1)=YD(2) 

 4226 YT1=YT2 

 4227 READ(LUT,*,END=130)YD(2),DD(2),(VALS(2,N),N=1,NSIG) 

 4228 CALL YTIME8(YT2,DD(2),YD(2)) 

 4229 GOTO 100 

 4230 ENDIF 

 4231 GOTO 150 

 4232 130 IEND=1 

 4233 WRITE(ISCR,140)LUT 

 4234 140 FORMAT(1X,'** NO MORE DATA ON UNIT=',I2,' **') 

 4235 RETURN 

 4236 c interpolate 

 4237 150 F2=(YT-YT1)/(YT2-YT1) 

 4238 DO 160 N=1,NSIG 

 4239 160 FINAL(N)=(1.-F2)*VALS(1,N)+F2*VALS(2,N) 

 4240 RETURN 

 4241 END 

 4242 C 

 4243 c--------------------------------------------------------------------- 

 4244 C 

 4245 SUBROUTINE IRR(IUNIT,ISCR,LUT,IEND,DD,YD,NSIG,NN,VALS) 

 4246 DIMENSION DD(2),YD(2),VALS(2,NN) 

 4247 CHARACTER*40 FDATA 

 4248 C INITIAL READ OF DATA 

 4249 IEND=0 

 4250 READ(IUNIT,100) 

 4251 100 FORMAT(1X) 

 4252 READ(IUNIT,*)NSIG 

 4253 IF(NSIG.GT.0)GOTO 110 

 4254 WRITE(ISCR,*)' NO INPUT DATA ' 

 4255 GOTO 140 

 4256 c read file 
46

 4257 110 READ(IUNIT,120)FDATA 

 4258 120 FORMAT(A40) 

 4259 WRITE(ISCR,130)FDATA,NSIG,LUT 

 4260 130 FORMAT(5X,'FILE NAME=',A40,/,5x,'NSIG=',I2,' LUT=',I2) 

 4261 CALL FFOPEN(LUT,FDATA) 

 4262 READ(LUT,*,END=140)YD(1),DD(1),(VALS(1,N),N=1,NSIG) 

 4263 READ(LUT,*,END=140)YD(2),DD(2),(VALS(2,N),N=1,NSIG) 

 4264 IEND=0 

 4265 GOTO 150 

 4266 140 IEND=1 

 4267 150 RETURN 

 4268 END 

 4269 c 

 4270 c-------------------------------------------------------- 

 4271 c 

 4272 SUBROUTINE RDWIND(I,IEND) 

 4273 c PURPOSE - TO READ THE METEOROLOGICAL FILES 

 4274 C VARIABLES - 

 4275 C ITYPE1 = INDEX FOR WIND OR STRESS. 

 4276 C 1=WIND, 2=STRESS 

 4277 C ITYPE2 = INDEX FOR HORIZONTAL ATMOSPHERIC PRESSURE GRADIENT 

 4278 C 0=NONE, 1=VALUES TO BE READ 

 4279 C ITYPE3 = INDEX FOR COORDINATES FOR WIND/STRESS AND PRESSURE 

 4280 C 0=IN MODEL COORDS 

 4281 C 1=IN EAST, NORTH 

 4282 INCLUDE 'COMM20.FOR' 

 4283 COMMON/METOX/TMET8(2),ITYPE1 

 4284 DIMENSION ATX(NSIZE,MSIZE),ATY(NSIZE,MSIZE) 

 4285 REAL*8 TMET8,UTM 

 4286 c set end-of-file index 

 4287 IEND=0 

 4288 c read data 

 4289 READ(LUWND,END=110)DATE1,DATE2,ITYPE1,ITYPE2,ITYPE3,NIX,MIX 

 4290 IF(DATE1.GT.370.)THEN 

 4291 YMET(I)=DATE1 

 4292 DMET(I)=DATE2 

 4293 ELSE 

 4294 YMET(I)=DATE2 

 4295 DMET(I)=DATE1 

 4296 ENDIF 

 4297 c read arrays 

 4298 DPADX=0. 

 4299 DPADY=0. 

 4300 IF(NIX.GT.1.AND.MIX.GT.1)THEN 

 4301 IF(ITYPE2.EQ.0)READ(LUWND)((ATX(N,M),N=1,NIX),M=1,MIX), 

 4302 1 ((ATY(N,M),N=1,NIX),M=1,MIX) 

 4303 IF(ITYPE2.EQ.1)READ(LUWND)((ATX(N,M),N=1,NIX),M=1,MIX), 

 4304 1 ((ATY(N,M),N=1,NIX),M=1,MIX),DPADX,DPADY 

 4305 ELSE 

 4306 c read single wind speed/stress 

 4307 IF(ITYPE2.EQ.0)READ(LUWND)AT1,AT2 

 4308 IF(ITYPE2.EQ.1)READ(LUWND)AT1,AT2,DPADX,DPADY 

 4309 DO M=1,MSIZE 

 4310 DO N=1,NSIZE 

 4311 ATX(N,M)=AT1 

 4312 ATY(N,M)=AT2 

 4313 ENDDO 

 4314 ENDDO 

 4315 ENDIF 

 4316 C rotate winds to model basin angle 

 4317 IF(ITYPE3.EQ.1)THEN 

 4318 ARG=RAD*BSNANG 

 4319 DO M=1,MSIZE 

 4320 DO N=1,NSIZE 

 4321 ATX1=-COS(ARG)*ATY(N,M)-SIN(ARG)*ATX(N,M) 

 4322 ATY1= COS(ARG)*ATX(N,M)-SIN(ARG)*ATY(N,M) 

 4323 ATX(N,M)=ATX1 

 4324 ATY(N,M)=ATY1 

 4325 ENDDO 

 4326 ENDDO 

 4327 DPADX1=-COS(ARG)*DPADY-SIN(ARG)*DPADX 

 4328 DPADY1= COS(ARG)*DPADX-SIN(ARG)*DPADY 

 4329 DPADX=DPADX1 

 4330 DPADY=DPADY1 

 4331 ENDIF 

 4332 c create date 

 4333 CALL YTIME8(UTM,DMET(I),YMET(I)) 

 4334 TMET8(I)=UTM 

 4335 WRITE(ISCR,100)I,NSTI,ITYPE1,ITYPE2,ITYPE3,DMET(I),YMET(I), 

 4336 1 TMET8(I),NIX,MIX 

 4337 100 FORMAT(5X,'RDWIND: I,NSTI=',2I6,' ITYPE1,2,3=',3I6,/, 

 4338 1 5x,'DY,YR=',2F12.5,' TMET8(I)=',F12.7,/,5x,'NIX,MIX=',2I5) 

 4339 WRITE(ISCR,105)ATX(1,1),ATY(1,1),DPADX,DPADY 

 4340 105 FORMAT(5x,'ATX,ATY(1,1)=',2E12.4,' DPADX,DPADY=',2E12.4) 

 4341 c save data 

 4342 DO N=1,NSIZE 

 4343 DO M=1,MSIZE 

 4344 FX(I,N,M)=ATX(N,M) 

 4345 FY(I,N,M)=ATY(N,M) 

 4346 ENDDO 

 4347 ENDDO 

 4348 IENDWN=IEND 

 4349 RETURN 

 4350 c end of data 

 4351 110 IEND=1 

 4352 WRITE(6,*)'END OF MET DATA REACHED' 

 4353 IENDWN=IEND 

 4354 RETURN 

 4355 END 

 4356 c======================================================================= 

 4357 C MECCA: ANALYS 

 4358 C 

 4359 C----------------------------------------------------------------------- 

 4360 C 

 4361 SUBROUTINE ANALYS 

 4362 

 4363 C JULY 1988 K. HESS MEAD VAX780 

 4364 C PURPOSE - TO CALL THE ANALYSIS ROUTINES 

 4365 INCLUDE 'COMM20.FOR' 

 4366 CALL CHECK2 

 4367 RETURN 

 4368 END 

 4369 C 

 4370 C----------------------------------------------------------------------- 

 4371 C 

 4372 SUBROUTINE CHECK2 

 4373 

 4374 C JULY 1988 K. HESS MEAD VAX780 

 4375 C PURPOSE - TO CALL THE ANALYSIS ROUTINES 

 4376 INCLUDE 'COMM20.FOR' 

 4377 C CHECK FOR LARGE WATER LEVEL VALUES 

 4378 ISTOP=0 

 4379 SEMAX=3. 

 4380 DO 110 N=1,NMAX 

 4381 DO 110 M=1,MMAX 

 4382 IF(ABS(SE(N,M)).GT.SEMAX)THEN 

 4383 WRITE(6,105)NSTI,N,M,SE(N,M),D(N,M) 

 4384 105 FORMAT(1X,'ANALYSIS: NSTI=',I6,' N,M=',2I4,' SE=',F6.2,' D=',F6.2) 

 4385 ISTOP=1 

 4386 ENDIF 

 4387 110 CONTINUE 

 4388 

 4389 C CHECK FOR LARGE SALINITY VALUES 

 4390 IF(KONCEN.EQ.0)RETURN 

 4391 IF(IPRNT1.EQ.0)RETURN 

 4392 SALMIN= 1.E+10 

 4393 SALMAX=-1.E+10 

 4394 DO M=1,MMAX 

 4395 DO N=1,NMAX 

 4396 IF(IFIELD(N,M).GT.0)THEN 

 4397 DO L=1,LBOT 

 4398 c check for max 

 4399 IF(S(L,N,M).GT.SALMAX)THEN 

 4400 MSMAX=M 

 4401 NSMAX=N 

 4402 LSMAX=L 

 4403 SALMAX=S(L,N,M) 

 4404 ENDIF 

 4405 IF(S(L,N,M).LT.SALMIN)THEN 

 4406 MSMIN=M 

 4407 NSMIN=N 

 4408 LSMIN=L 

 4409 SALMIN=S(L,N,M) 

 4410 ENDIF 

 4411 ENDDO 

 4412 ENDIF 

 4413 ENDDO 

 4414 ENDDO 

 4415 WRITE(6,150)UT,NSTI,SALMAX,MSMAX,NSMAX,LSMAX 

 4416 150 FORMAT(1X,'AT UT=',F10.4,' NSTI=',I6,T30,' SALMAX=',F10.2, 

 4417 1 ' AT M,N,L=',3I4) 

 4418 WRITE(6,160)SALMIN,MSMIN,NSMIN,LSMIN 

 4419 160 FORMAT(T30,' SALMIN=',F10.2,' AT M,N,L=',3I4) 

 4420 

 4421 RETURN 

 4422 END 

 4423 C======================================================================= 

 4424 C MECCA FILE : CONC.FOR - CONCENTRATION SUBROUTINES 

 4425 C----------------------------------------------------------------------- 

 4426 C 

 4427 SUBROUTINE CONCZ 

 4428 C MARCH 1986 K. W. HESS (LAST REVISED 23 JULY 87) 

 4429 C PURPOSE - SUPER-STREAMLINED, SQUARE-GRID VERSION. 

 4430 C TO COMPUTE NEW DISTRIBUTION OF CONCENTRATE, 

 4431 C WHICH INCLUDES VARIABLE WIDTH AND VARIABLE HORIZONTAL 

 4432 C VISCOSITY. NEW FORMULATION OF UPPER BOUNDARY CONDITIO 

 4433 C INITIALIZE BOUNDARY CONCENTRATIONS 

 4434 INCLUDE 'COMM20.FOR' 

 4435 COMMON/BNDY4/ISALT,ITEMP,NB 

 4436 c CHECK FOR TIME 

 4437 IF(HR1.LT.HRCON1)RETURN 

 4438 C SET INDICES: 1=DO IT, 2=SKIP 

 4439 ISALT=2 

 4440 IF(KONCEN.EQ.1.OR.KONCEN.EQ.3)ISALT=1 

 4441 ITEMP=2 

 4442 IF(KONCEN.EQ.2.OR.KONCEN.EQ.3)ITEMP=1 

 4443 

 4444 C GET OCEAN BOUNDARY CONDITIONS 

 4445 CALL BNDRY3 

 4446 C GET RIVER BOUNDARY CONDITIONS 

 4447 CALL BNDRY4 

 4448 C SOLVE GENERALIZED TRANSPORT EQUATION 

 4449 CALL GFLUX 

 4450 END 

 4451 C 

 4452 C----------------------------------------------------------------------- 

 4453 C 

 4454 SUBROUTINE BNDRY3 

 4455 C OCTOBER 1984 K. W. HESS MEAD VAX11/750 

 4456 C PURPOSE - TO SET THE OCEANIC SALINITY AND TEMPERATURE 

 4457 C BOUNDARY CONDITIONS 

 4458 C VARIABLES - 

 4459 C IDIR = INFLOW DIRECTION PARAMETER:1=X DIR, 2=Y DIR 

 4460 C ISALT,ITEMP = SET INDICES: 1=DO IT, 2=SKIP 

 4461 C ISENSE = INFLOW PARAMETER:1=INFLOW IS IN POSITIVE DIR. 

 4462 C 2=INFLOW IS IN NEGATIVE DIRECTION 

 4463 C ITPO = TYPE OF OCEAN BOUNDARY CONDITION 

 4464 C +/-1 : OUTFLOW IN +/-X DIRECTION 

 4465 C +/-2 : OUTFLOW IN +/-Y DIRECTION 

 4466 C JTPO = TYPE OF OCEAN BOUNDARY CONDITION 

 4467 C 1 : WATER LEVEL SPECIFICATION 

 4468 C 2 : TRANSPORT OUTFLOW 

 4469 C 3 : ORLANSKI RADIATION OUTFLOW (REQUIRES WL) 

 4470 C 4 : REIMANN INVARIENT RADIATION OUTFLOW (REQUIRES

 4471 C ITPR = DIRECTION OF RIVER BOUNDARY INFLOW TO ESTUARY 

 4472 C +/-1 : INFLOW IN +/-X DIRECTION 

 4473 C +/-2 : INFLOW IN +/-Y DIRECTION 

 4474 C JTPR = TYPE OF RIVER BOUNDARY CONDITION 

 4475 C 1 : CHANNEL 

 4476 C 2 : FALLS 

 4477 C QRIV = RIVER FLOWRATE (M**3/S) 

 4478 INCLUDE 'COMM20.FOR' 

 4479 COMMON/BNDY4/ISALT,ITEMP,NB 

 4480 DIMENSION SN(LSIZE),TN(LSIZE) 

 4481 CHARACTER*6 ANAMES(2) 

 4482 DATA ANAMES/'OUTFLO','INFLO '/,HRINF/6./,IP/0/ 

 4483 C MAKE SURE THERE ARE BOUNDARIES TO SET 

 4484 IF(NUMOBC.LE.0)RETURN 

 4485 C SET OCEANIC CONDITIONS 

 4486 CALL BSTATE 

 4487 NHRINF=HRINF*IHR 

 4488 CIN1=DTI/DL 

 4489 IP1=IPRNT1 

 4490 IF(IP.EQ.0)IP1=0 

 4491 C LOOP THRU OCEANIC BOUNDARIES 

 4492 NB=0 

 4493 DO 360 IB=1,NUMOBC 

 4494 IF(IP1.EQ.1)WRITE(ISCR,*)'OCEAN SALINITY BND: IB=',IB, 

 4495 1 ' NSTI=',NSTI 

 4496 MF=MB1(IB) 

 4497 ML=MB2(IB) 

 4498 NF=NB1(IB) 

 4499 NL=NB2(IB) 

 4500 C SET DIRECTIONAL PARAMETER, IDIR: 1=X, 2=Y 

 4501 IDIR=IABS(ITPO(IB)) 

 4502 ISENSE=(3-ISIGN(1,ITPO(IB)))/2 

 4503 C OUTFLOW SENSE:FOR +DIRECTION, ISENSE=1; FOR -DIR, ISENSE=2 

 4504 ND1=(IDIR/2)*(2*ISENSE-3) 

 4505 MD1=(1-IDIR/2)*(2*ISENSE-3) 

 4506 C LOOP THRU EACH GRID 

 4507 DO 295 N=NF,NL 

 4508 DO 295 M=MF,ML 
47

 4509 N1=N+ND1 

 4510 M1=M+MD1 

 4511 NB=NB+1 

 4512 C LOOP OVER DEPTHS 

 4513 DO 220 L=1,LBOT 

 4514 GOTO(100,110)IDIR 

 4515 100 UL=UE(N,M-2+ISENSE)+U(L,N,M-2+ISENSE) 

 4516 GOTO 120 

 4517 110 UL=VE(N-2+ISENSE,M)+V(L,N-2+ISENSE,M) 

 4518 120 CONTINUE 

 4519 IF(-UL*ISIGN(1,ISENSE-2).LE.0.0)GOTO 150 

 4520 C OUTFLOW CONDITIONS 

 4521 130 JFLOW=1 

 4522 NSTINF(L,NB)=NSTIT 

 4523 C FIRST-ORDER ADVECTION 

 4524 F0=ABS(CIN1*UL) 

 4525 F1=F0*(2-ISALT) 

 4526 F2=F0*(2-ITEMP) 

 4527 SN(L)=(S(L,N,M)*(1.-F1)+F1*S(L,N1,M1)) 

 4528 TN(L)=(T(L,N,M)*(1.-F2)+F2*T(L,N1,M1)) 

 4529 GOTO 200 

 4530 C INFLOW CONDITIONS 

 4531 150 JFLOW=2 

 4532 F0=FLOAT(ISPLIT)/FLOAT(MAX0(ISPLIT,NSTINF(L,NB)+NHRINF-NSTIT)) 

 4533 F1=F0*(2-ISALT) 

 4534 F2=F0*(2-ITEMP) 

 4535 SN(L)=(S(L,N,M)*(1.-F1)+F1*SBND(L,NB)) 

 4536 TN(L)=(T(L,N,M)*(1.-F2)+F2*TBND(L,NB)) 

 4537 200 CONTINUE 

 4538 220 CONTINUE 

 4539 C CHECK FOR POSITIVE VALUES 

 4540 IF(ICPOS.EQ.0)GOTO 240 

 4541 DO L=1,LBOT 

 4542 SN(L)=AMAX1(SN(L),0.0) 

 4543 TN(L)=AMAX1(TN(L),0.0) 

 4544 ENDDO 

 4545 240 CONTINUE 

 4546 DO L=1,LBOT 

 4547 T(L,N,M)=TN(L) 

 4548 S(L,N,M)=SN(L) 

 4549 ENDDO 

 4550 295 CONTINUE 

 4551 360 CONTINUE 

 4552 370 CONTINUE 

 4553 RETURN 

 4554 END 

 4555 C 

 4556 C----------------------------------------------------------------------- 

 4557 C 

 4558 SUBROUTINE BNDRY4 

 4559 C NOVEMBER 1986 HESS & PYTLOWANY MEAD VAX 

 4560 C PURPOSE - TO COMPUTE THE RIVERINE SALINITY AND TEMPERATURE 

 4561 C BOUNDARY CONDITIONS 

 4562 INCLUDE 'COMM20.FOR' 

 4563 COMMON/BNDY4/ISALT,ITEMP,NB 

 4564 DIMENSION FSZ(LSIZE) 

 4565 DO L=1,LBOT 

 4566 FSZ(L)=2*(1.-FLOAT(L-1)/FLOAT(LBOT-1)) 

 4567 ENDDO 

 4568 IP=0 

 4569 IP=IPRNT1 

 4570 C RIVER FLOW BOUNDARIES 

 4571 IF(NUMRIV.LE.0)GOTO 300 

 4572 NB=0 

 4573 DO 250 NR=1,NUMRIV 

 4574 MF=MR1(NR) 

 4575 ML=MR2(NR) 

 4576 NF=NR1(NR) 

 4577 NL=NR2(NR) 

 4578 DO 220 M=MF,ML 

 4579 DO 220 N=NF,NL 

 4580 NB=NB+1 

 4581 IF(JTPR(NR).EQ.2)GOTO 130 

 4582 C FLUME CONDITION 

 4583 DO 100 L=1,LBOT 

 4584 IF(ISALT.EQ.1)S(L,N,M)=SBND(L,NB+NBCELO) 

 4585 100 IF(ITEMP.EQ.1)T(L,N,M)=TBND(L,NB+NBCELO) 

 4586 GOTO 220 

 4587 C WATER FALLS CONDITION 

 4588 130 SAL=SBND(1,NB+NBCELO) 

 4589 TMP=TBND(1,NB+NBCELO) 

 4590 KMAX=1+ML-MF+NL-NF 

 4591 ND=N 

 4592 MD=M 

 4593 VOL0=(D(ND,MD)+SE(ND,MD))*DQ*AREA(ND,MD)*DL**2 

 4594 VOL1=DTI*RATE(NR)*DQ/FLOAT(KMAX) 

 4595 F3=VOL1/(VOL0+VOL1) 

 4596 IF(IP.EQ.1)WRITE(ISCR,140)NR,ND,MD 

 4597 140 FORMAT(3X,'RIVER: NR=',I2,' N,M=',2I4) 

 4598 IF(IP.EQ.1)WRITE(ISCR,*)'SAL,TMP=',SAL,TMP,' F3=',F3 

 4599 DO 170 L=1,LBOT 

 4600 F2=F3*FSZ(L) 

 4601 F1=1.-F2 

 4602 IF(ISALT.EQ.1)S(L,ND,MD)=(S(L,ND,MD)*F1+SAL*F2) 

 4603 IF(ITEMP.EQ.1)T(L,ND,MD)=(T(L,ND,MD)*F1+TMP*F2) 

 4604 IF(IP.EQ.1)WRITE(ISCR,160)L,S(L,ND,MD),T(L,ND,MD) 

 4605 160 FORMAT(3X,'L=',I3,' S=',F5.2,' T=',F5.2) 

 4606 170 CONTINUE 

 4607 220 CONTINUE 

 4608 250 CONTINUE 

 4609 300 RETURN 

 4610 END 

 4611 C 

 4612 C----------------------------------------------------------------------- 

 4613 C 

 4614 SUBROUTINE BSTATE 

 4615 C FEBRUARY 1996 K. W. HESS CEOB SGI/IRIS 

 4616 C PURPOSE - TO SET THE RIVERINE AND OCEANIC SALINITY AND 

 4617 C TEMPERATURE BOUNDARY STATES BY INTERPOLATION 

 4618 C VARIABLES - 

 4619 C SBND(L,NB) = INTERPOLATED STATE OF BOUNDARY SALINITY AT 

 4620 C LEVEL L AND BOUNDARY GRID NB 

 4621 C TBND(L,NB) = INTERPOLATED STATE OF BOUNDARY TEMPERATURE 

 4622 C NBC = TOTAL NUMBER OF OCEANIC AND RIVERINE 

 4623 C BOUNDARY GRIDS (UP TO 100 ALLOWED) 

 4624 INCLUDE 'COMM20.FOR' 

 4625 COMMON/BNDY4/ISALT,ITEMP,NB 

 4626 DIMENSION SFINL(LSIZE),TFINL(LSIZE),TRFINL(NDRIV2) 

 4627 C SET STANDARD CONDITIONS 

 4628 IF(IPRNT1.EQ.1)WRITE(ISCR,100)UT,HR1,NSTI 

 4629 100 FORMAT(/,1X,'BSTATE : UT=',F10.4,' CUM HR=',F10.2,' NSTI=',I6) 

 4630 C set to default values 

 4631 DO L=1,LBOT 

 4632 SFINL(L)=SAL0 

 4633 TFINL(L)=TMP0 

 4634 DO N=1,NM2SIZ 

 4635 SBND(L,N)=SAL0 

 4636 TBND(L,N)=TMP0 

 4637 ENDDO 

 4638 ENDDO 

 4639 DO N=1,NDRIV2 

 4640 TRFINL(N)=TMP0 

 4641 ENDDO 

 4642 c initialize cell counts 

 4643 NBCEL=0 

 4644 NBCELO=0 

 4645 c check on ocean conditions 

 4646 IF(NUMOBC.LE.0)GOTO 300 

 4647 C SET OCEANIC SALINITY CONDITIONS 

 4648 IF(KONCEN.EQ.2.OR.NSIGS.EQ.0.OR.IENDSO.EQ.1)GOTO 150 

 4649 c read more salinity data 

 4650 CALL RR(YT,ISCR,LUSAL,IENDSO,DSAL,YSAL,NSIGS,LSIZE,SALOCN,SFINL) 

 4651 c OCEAN TEMP 

 4652 150 IF(KONCEN.EQ.1.OR.NSIGTO.EQ.0.OR.IENDTO.EQ.1)GOTO 165 

 4653 c read more ocean temperature data 

 4654 CALL RR(YT,ISCR,LUOCT,IENDTO,DOTP,YOTP,NSIGTO,LSIZE,TMPOCN,TFINL) 

 4655 165 IF(IPRNT1.EQ.0)GOTO 200 

 4656 DO L=1,LBOT 

 4657 WRITE(ISCR,170)L,SFINL(L),TFINL(L) 

 4658 170 FORMAT(3x,'L=',I2,' SFINL=',F7.3,' TFINL=',F7.3) 

 4659 ENDDO 

 4660 C LOOP THRU OCEANIC BOUNDARIES 

 4661 200 DO 250 IB=1,NUMOBC 

 4662 C LOOP THRU EACH GRID 

 4663 DO 250 N=NB1(IB),NB2(IB) 

 4664 DO 250 M=MB1(IB),MB2(IB) 

 4665 NBCEL=NBCEL+1 

 4666 NBCELO=NBCELO+1 

 4667 C SET VALUES OVER DEPTH 

 4668 DO 240 L=1,LBOT 

 4669 SBND(L,NBCEL)=SFINL(L) 

 4670 240 TBND(L,NBCEL)=TFINL(L) 

 4671 250 CONTINUE 

 4672 C 

 4673 C RIVER BOUNDARIES 

 4674 300 IF(NUMRIV.LE.0)GOTO 400 

 4675 c read more river temperature data 

 4676 IF(KONCEN.EQ.1.OR.NSIGRT.EQ.0.OR.IENDRT.EQ.1)GOTO 310 

 4677 CALL RR(YT,ISCR,LURVT,IENDRT,DRVT,YRVT,NSIGRT,NDRIV2,TRIV,TRFINL) 

 4678 C LOOP THRU THE RIVERS 

 4679 310 DO 340 NR=1,NUMRIV 

 4680 C LOOP THRU THE GRIDS 

 4681 DO 340 M=MR1(NR),MR2(NR) 

 4682 DO 340 N=NR1(NR),NR2(NR) 

 4683 NBCEL=NBCEL+1 

 4684 C LOOP OVER DEPTH 

 4685 DO 320 L=1,LBOT 

 4686 SBND(L,NBCEL)=0.0 

 4687 320 TBND(L,NBCEL)=TRFINL(NR) 

 4688 IF(IPRNT1.EQ.1)WRITE(ISCR,330)NR,TRFINL(NR) 

 4689 330 FORMAT(3x,'NR=',I2,' TRFINL=',F7.3) 

 4690 340 CONTINUE 

 4691 400 CONTINUE 

 4692 

 4693 RETURN 

 4694 END 

 4695 C 

 4696 C----------------------------------------------------------------------- 

 4697 C 

 4698 SUBROUTINE GFLUX 

 4699 C JUNE 1996 K. W. HESS 

 4700 C PURPOSE - TO COMPUTE NEW DISTRIBUTION OF CONCENTRATE, 

 4701 C WHICH INCLUDES VARIABLE WIDTH AND VARIABLE HORIZONTAL 

 4702 C VISCOSITY. NEW FORMULATION OF UPPER BOUNDARY 

 4703 C CONDITION. 

 4704 C VARIABLES - 

 4705 C SN() = NEW (UPDATED) SALINITY 

 4706 C SC(,) = SALINITY AT ROW AT START OF UPDATE 

 4707 C SM(,) = SALINITY AT PREVIOUS ROW AT START OF UPDATE 

 4708 C FA(),FB() = RECURSION ARRAYS FOR SALINITY, TEMPERATURE 

 4709 C FTOP = FLUX OF C AT THE AIR-WATER INTERFACE 

 4710 

 4711 c L-1 + U(L-1), W, S 

 4712 c | 

 4713 c ------- | DV(L-1) ---------- ULM, (DM,GM), FZZA(L-1) 

 4714 c | 

 4715 c L + U(L), W, S FFCC(L) 

 4716 c | 

 4717 c ------- | DV(L) ---------- ULP, DP,GP, FFZA(L),FFZD(L) 

 4718 c | 

 4719 c L+1 + U(L+1), W, S 

 4720 

 4721 INCLUDE 'COMM20.FOR' 

 4722 COMMON/BNDY4/ISALT,ITEMP,NB 

 4723 DIMENSION SN(LSIZE),SC(LSIZE,NSIZE),SM(LSIZE,NSIZE), 

 4724 2 TN(LSIZE),TC(LSIZE,NSIZE),TM(LSIZE,NSIZE),TRAD(LSIZE), 

 4725 2 FFCC(LSIZE),FFXM(LSIZE),FFXP(LSIZE),FFYM(LSIZE),FFYP(LSIZE), 

 4726 3 FFZA(LSIZE),FFZD(LSIZE),DEN(LSIZE),PROD(LSIZE) 

 4727 DATA IP/0/ 

 4728 

 4729 C1=DTI/(4.*DQ) 

 4730 C2=DTI/DQ**2 

 4731 C3=DHAH*DTI/(2.*DL**2) 

 4732 C4=DTI/(2.*DL) 

 4733 C5=DTI/(16.*DL) 

 4734 

 4735 C INITIALIZE SURFACE HEAT FLUX 

 4736 IF(KONCEN.GE.2)CALL HEAT1 

 4737 C 

 4738 C SOLVE GENERALIZED TRANSPORT EQUATION 

 4739 C 

 4740 C LOOP DOWN THE LINES 

 4741 DO 400 M=1,MMAX 

 4742 C STORE VALUES 

 4743 DO 130 N=1,NMAX 

 4744 DO 130 L=1,LBOT 

 4745 IF(M.GT.1)GOTO 110 

 4746 SM(L,N)=S(L,N,M) 

 4747 TM(L,N)=T(L,N,M) 

 4748 GOTO 120 

 4749 110 SM(L,N)=SC(L,N) 

 4750 TM(L,N)=TC(L,N) 

 4751 120 SC(L,N)=S(L,N,M) 

 4752 TC(L,N)=T(L,N,M) 

 4753 130 CONTINUE 

 4754 

 4755 C RUN ACROSS ROW 

 4756 NA=NAB(M)/1000 

 4757 NB=MOD(NAB(M),1000) 

 4758 IF(NA.GT.NB)GOTO 400 

 4759 MM=MAX0(M-1,1) 

 4760 MP=MIN0(MMAX,M+1) 
48

 4761 C LOOP ACROSS ROWS 

 4762 DO 390 N=NA,NB 

 4763 IF(IFIELD(N,M).LT.10.OR.IFIELD(N,M)/10.EQ.KOCNBC)GOTO 390 

 4764 NM=MAX0(N-1,1) 

 4765 NP=MIN0(NMAX,N+1) 

 4766 C COMPUTE REPEATEDLY-USED TERMS 

 4767 H=D(N,M)+SE(N,M)+E 

 4768 ANM=AREA(N,M) 

 4769 F1=C1*ANM 

 4770 F2=C2*ANM/H 

 4771 HH=ANM*H 

 4772 SS=ANM*(SE(N,M)-SOLD(N,M)) 

 4773 C HORIZONTAL X-DIRECTION FLUX TERMS 

 4774 UHO1=BX(N,M-1)*C4*UHOLD(N,M-1) 

 4775 H1=BX(N,M-1)*C5*(H+D(N,M-1)+SE(N,M-1)) 

 4776 DH1=BX(N,M-1)*C3*FLOAT(MFLUX(N,MM)) 

 4777 UHO2=BX(N,M)*C4*UHOLD(N,M) 

 4778 H2=BX(N,M)*C5*(H+D(N,M+1)+SE(N,M+1)) 

 4779 DH2=BX(N,M)*C3*FLOAT(MFLUX(N,M)) 

 4780 C HORIZONTAL Y-DIRECTION FLUX TERMS 

 4781 VHO1=BY(N-1,M)*C4*VHOLD(N-1,M) 

 4782 H3=BY(N-1,M)*C5*(H+D(N-1,M)+SE(N-1,M)) 

 4783 DH3=BY(N-1,M)*C3*FLOAT(NFLUX(NM,M)) 

 4784 VHO2=BY(N,M)*C4*VHOLD(N,M) 

 4785 H4=BY(N,M)*C5*(H+D(N+1,M)+SE(N+1,M)) 

 4786 DH4=BY(N,M)*C3*FLOAT(NFLUX(N,M)) 

 4787 C 

 4788 C INITIAL VELOCITIES 

 4789 L=LBOT 

 4790 ULP1=U(L,N,M-1)+U(L-1,N,M-1) 

 4791 ULP2=U(L,N,M)+U(L-1,N,M) 

 4792 VLP1=V(L,N-1,M)+V(L-1,N-1,M) 

 4793 VLP2=V(L,N,M)+V(L-1,N,M) 

 4794 C LOOP THRU THE LAYERS, STARTING AT BOTTOM 

 4795 DO 150 L=LBOT,1,-1 

 4796 LM=MAX0(1,L-1) 

 4797 C VERTICAL ADVECTIVE AND DIFFUSIVE FLUX TERMS: units are m/s 

 4798 FFZA(L)=F1*(W(L,N,M)+W(L+1,N,M)) ! Gp 

 4799 FFZD(L)=F2*DV(L,N,M) ! Dp 

 4800 C GET NEW VELOCITIES 

 4801 LEM=L-1 

 4802 IF(L.EQ.1)LEM=L+1 

 4803 ULM1=U(L,N,M-1)+U(LEM,N,M-1) 

 4804 ULM2=U(L,N,M)+U(LEM,N,M) 

 4805 VLM1=V(L,N-1,M)+V(LEM,N-1,M) 

 4806 VLM2=V(L,N,M)+V(LEM,N,M) 

 4807 C GET HORIZONTAL GENERALIZED FLUX COEFFICIENTS : units are meters 

 4808 FFXM(L)= (H1*(ULM1+ULP1)+UHO1)+DH1*(AH3(L,N,M)+AH3(L,N,M-1)) 

 4809 FFCC(L)= (H1*(ULM1+ULP1)+UHO1)-DH1*(AH3(L,N,M)+AH3(L,N,M-1)) 

 4810 1 -(H2*(ULM2+ULP2)+UHO2)-DH2*(AH3(L,N,M)+AH3(L,N,M+1)) 

 4811 2 +(H3*(VLM1+VLP1)+VHO1)-DH3*(AH3(L,N,M)+AH3(L,N-1,M)) 

 4812 3 -(H4*(VLM2+VLP2)+VHO2)-DH4*(AH3(L,N,M)+AH3(L,N+1,M)) 

 4813 4 +HH 

 4814 FFXP(L)=-(H2*(ULM2+ULP2)+UHO2)+DH2*(AH3(L,N,M)+AH3(L,N,M+1)) 

 4815 FFYM(L)= (H3*(VLM1+VLP1)+VHO1)+DH3*(AH3(L,N,M)+AH3(L,N-1,M)) 

 4816 FFYP(L)=-(H4*(VLM2+VLP2)+VHO2)+DH4*(AH3(L,N,M)+AH3(L,N+1,M)) 

 4817 C SAVE UPPER (LM) VELOCITIES IN LOWER (LP) VELOCITIES 

 4818 ULP1=ULM1 

 4819 ULP2=ULM2 

 4820 VLP1=VLM1 

 4821 VLP2=VLM2 

 4822 150 CONTINUE 

 4823 FFZA(LBOT)=0.0 

 4824 FFZD(LBOT)=0.0 

 4825 c 

 4826 c LOOP UP COLUMN, COMPUTE REPEATED QUANTITIES 

 4827 DEN(LBOT)=1./(HH+SS+2.*(FFZA(LAYRS)+FFZD(LAYRS))) 

 4828 FB(LBOT)=2.*(FFZD(LAYRS)-FFZA(LAYRS))*DEN(LBOT) 

 4829 DO 160 L=LAYRS,2,-1 

 4830 LM=L-1 

 4831 DEN(L)=1./(HH+SS+FFZA(LM)-FFZA(L)+FFZD(LM)+FFZD(L)-FB(L+1)* 

 4832 1 (FFZA(L)+FFZD(L))) 

 4833 FB(L)=(FFZD(LM)-FFZA(LM))*DEN(L) 

 4834 160 CONTINUE 

 4835 DEN(1)=1./(HH+SS+2.*(FFZD(1)-FFZA(1)-FB(2)*(FFZA(1)+FFZD(1)))) 

 4836 C 

 4837 C SALINITY CALCULATIONS 

 4838 GOTO(200,250),ISALT 

 4839 200 CONTINUE 

 4840 C BOTTOM CONDITIONS 

 4841 L=LBOT 

 4842 CFLUX= FFXM(L)*SM(L,N) 

 4843 1 +FFYM(L)*SC(L,NM)+FFCC(L)*SC(L,N)+FFYP(L)*SC(L,NP) 

 4844 2 +FFXP(L)*S(L,N,MP) 

 4845 FA(L)=CFLUX*DEN(L) 

 4846 C CORE SALINITY 

 4847 DO 230 L=LAYRS,2,-1 

 4848 CFLUX= FFXM(L)*SM(L,N) 

 4849 1 +FFYM(L)*SC(L,NM)+FFCC(L)*SC(L,N)+FFYP(L)*SC(L,NP) 

 4850 2 +FFXP(L)*S(L,N,MP) 

 4851 FA(L)=(CFLUX+FA(L+1)*(FFZA(L)+FFZD(L)))*DEN(L) 

 4852 230 CONTINUE 

 4853 C TOP CONDITIONS 

 4854 L=1 

 4855 CFLUX= FFXM(L)*SM(L,N) 

 4856 1 +FFYM(L)*SC(L,NM)+FFCC(L)*SC(L,N)+FFYP(L)*SC(L,NP) 

 4857 2 +FFXP(L)*S(L,N,MP) 

 4858 S(1,N,M)=(CFLUX+2.*FA(2)*(FFZA(1)+FFZD(1)))*DEN(1) 

 4859 c INVERT HERE 

 4860 DO L=2,LBOT 

 4861 S(L,N,M)=FA(L)+FB(L)*S(L-1,N,M) 

 4862 ENDDO 

 4863 C 

 4864 C TEMPERATURE 

 4865 250 GOTO(260,390),ITEMP 

 4866 C TOP AND BOTTOM UPWARD HEAT FLUX 

 4867 260 CALL HEATZ(N,M,TRAD,FTSURF) 

 4868 C BOTTOM CONDITIONS 

 4869 FTBOT=0. ! heat lost into bottom sediment 

 4870 L=LBOT 

 4871 TFLUX= FFXM(L)*TM(L,N) 

 4872 1 +FFYM(L)*TC(L,NM)+FFCC(L)*TC(L,N)+FFYP(L)*TC(L,NP) 

 4873 2 +FFXP(L)*T(L,N,MP) 

 4874 FA(LBOT)=(TFLUX+HH*(TRAD(L)+FTBOT))*DEN(L) 

 4875 C CORE TEMPERATURE 

 4876 DO 300 L=LAYRS,2,-1 

 4877 TFLUX= FFXM(L)*TM(L,N) 

 4878 1 +FFYM(L)*TC(L,NM)+FFCC(L)*TC(L,N)+FFYP(L)*TC(L,NP) 

 4879 2 +FFXP(L)*T(L,N,MP) 

 4880 FA(L)=(TFLUX+HH*TRAD(L)+FA(L+1)*(FFZA(L)+FFZD(L)))*DEN(L) 

 4881 300 CONTINUE 

 4882 C TOP TEMPERATURES 

 4883 L=1 

 4884 TFLUX= FFXM(L)*TM(L,N) 

 4885 1 +FFYM(L)*TC(L,NM)+FFCC(L)*TC(L,N)+FFYP(L)*TC(L,NP) 

 4886 2 +FFXP(L)*T(L,N,MP) 

 4887 T(1,N,M)=(TFLUX+HH*(TRAD(1)+FTSURF)+2.*FA(2)*(FFZA(L) 

 4888 1 +FFZD(L)))/(HH+SS+2.*(FFZD(L)-FFZA(L)-FB(2)*(FFZA(L)+FFZD(L)))) 

 4889 c INVERT HERE 

 4890 DO L=2,LBOT 

 4891 T(L,N,M)=FA(L)+FB(L)*T(L-1,N,M) 

 4892 ENDDO 

 4893 390 CONTINUE 

 4894 400 CONTINUE 

 4895 c make positive 

 4896 IF(ICPOS.EQ.0)RETURN 

 4897 DO 600 M=1,MMAX 

 4898 DO 600 N=1,NMAX 

 4899 DO 600 L=1,LBOT 

 4900 S(L,N,M)=AMAX1(S(L,N,M),0.0) 

 4901 600 T(L,N,M)=AMAX1(T(L,N,M),0.0) 

 4902 RETURN 

 4903 END 

 4904 C 

 4905 C----------------------------------------------------------------------- 

 4906 C 

 4907 SUBROUTINE HEAT1 

 4908 C APRIL 1985 K. W. HESS MEAD VAX 11/750 

 4909 C PURPOSE - TO COMPUTE OCEAN SURFACE HEAT FLUX CONSTANTS FOR 

 4910 C THIS TIMESTEP FOR ALL CELLS 

 4911 c INPUTS - 

 4912 C IHEAT = HEAT FLUX INDEX: 

 4913 C 0=NO HEAT, 

 4914 C 1=HEAT FLUX BUT WITH DAY OF YEAR CONSTANT (=NDAY

 4915 C 2=NORMAL HEATING 

 4916 C CLOUD = FRACTION OF SKY COVERED BY CLOUDS (0.0 - 1.0) 

 4917 C TAIRK = AIR TEMPERATURE (K) AT 10 M 

 4918 C W10 = WIND SPEED AT 10 M (M/S) 

 4919 C PA = ATMOSPHERIC PRESSURE (PASCALS) 

 4920 C RELHUM = RELATIVE HUMIDITY AT 10 M (0.0 - 1.0) 

 4921 C TW = WATER TEMPERATURE AT NEAR-SURFACE (K) 

 4922 C VARIABLES - 

 4923 C COSZ = COSINE OF Z 

 4924 C CDRGAW = AIR-WATER INTERFACIAL DRAG COEFFICIENT 

 4925 C DEC = SUN'S DECLINATION (ANGLE ABOVE ECLIPTIC) 

 4926 C EA,ES = SATURATION VAPOR PRESSURE (PASCALS) 

 4927 C HSOLAR = HOUR IN DAY ON A 24-HOUR CLOCK 

 4928 C NETDAY = DAY OF THE YEAR, COUNTED FROM JANUARY 1. 

 4929 C T0 = AIR TEMPERATURE AT SEA SURFACE (K) 

 4930 C CONSTANTS - 

 4931 C ALB = NET ALBEDO 

 4932 C ALV = LATENT HEAT OF VAPORIZATION (2.6 X 10 6 J/KG) 

 4933 C RHOA = AIR DENSITY (KG/M3) 

 4934 C RHOW = SEA WATER DENSITY (KG/M3) 

 4935 C CPAIR = SPECIFIC HEAT CAPACITY OF DRY AIR(J/KG/K) 

 4936 C CWATER = SPECIFIC HEAT CAPACITY OF WATER (J/KG/K) 

 4937 C SB = STEFAN-BOLTZMAN CONSTANT 

 4938 INCLUDE 'COMM20.FOR' 

 4939 DIMENSION VAL(4) 

 4940 DATA NDAY0/180/,IP/0/ 

 4941 C CLOUDINESS FUNCTION 

 4942 FCC(X)=1.-X 

 4943 T2KEL(TEMP)=TEMP+273.*(.5-SIGN(.5,TEMP-200.)) 

 4944 C GET DATA 

 4945 IF(NSIGM.EQ.0)THEN 

 4946 TAIRC=20. 

 4947 RELHUM=.7 

 4948 CLOUD=.5 

 4949 PA=1014.0*100. 

 4950 ELSE 

 4951 CALL RR(YT,ISCR,LUMET,IENDMT,DMET,YMET,NSIGM,4,VMET,VAL) 

 4952 TAIRC=VAL(1) 

 4953 RELHUM=VAL(2) 

 4954 CLOUD=VAL(3) 

 4955 PA=VAL(4)*100. 

 4956 ENDIF 

 4957 IF(IHEAT.EQ.1)NDAY=NDAY0 

 4958 IF(IHEAT.EQ.2)NDAY=UT 

 4959 IF(IPRNT1.EQ.1)WRITE(ISCR,100)TAIRC,RELHUM,CLOUD,PA,NDAY 

 4960 100 FORMAT(1X,'HEAT1: TAIRC=',F5.2,' RELHUM=',F5.3,' CLOUD=',F4.2, 

 4961 1 ' PA=',F10.2,' NDAY=',I3) 

 4962 C NEAR-SURFACE AIR TEMPERATURE 

 4963 TAIRK=TAIRC+273. 

 4964 T10=TAIRK 

 4965 C SOLAR ANGLES 

 4966 HSOLAR=24.*(UT-FLOAT(IFIX(UT)))-.5*DTI/3600. 

 4967 DEC=23.44*COS(FLOAT(172-NDAY)*PI/182.5) 

 4968 COSZ=SIN(BSNLAT*RAD)*SIN(DEC*RAD)+COS(BSNLAT*RAD)*COS(DEC*RAD)* 

 4969 1 COS((12.-HSOLAR)*PI/12.) 

 4970 C CONSTANTS 

 4971 CSOL1=FCC(CLOUD)*(1.-ALB)*SOLAR*(COSZ**2) 

 4972 CSOL2=0.10+1.085*COSZ 

 4973 CSOL3=(COSZ+2.7)/(10**5) 

 4974 C 10-METER VAPOR PRESSURE 

 4975 ES=611.0*10.**(7.5*(T10-273.16)/(T10-35.86)) 

 4976 EA=RELHUM*ES 

 4977 CEVP2=EA/(PA-(1.-EPSLON)*EA) 

 4978 CTOT=1./(RHOW*CWATER) 

 4979 CH1=SB*CTOT 

 4980 C ATMOSPHERIC LONG WAVE INWARD 

 4981 A=MIN0(1,IHEAT) 

 4982 QA=A*SB*TAIRK**4*(1.-0.261*EXP(-0.000777*(273.-TAIRK)**2)) 

 4983 IF(IPRNT1.EQ.1)WRITE(ISCR,200)COSZ,CSOL1,CSOL2,CSOL3 

 4984 200 FORMAT(1X,'COSZ,CSOL1,2,3=',4E10.2) 

 4985 RETURN 

 4986 END 

 4987 C 

 4988 C----------------------------------------------------------------------- 

 4989 C 

 4990 SUBROUTINE HEATZ(N,M,TRAD,FTSURF) 

 4991 C APRIL 1985 K. W. HESS MEAD VAX 11/750 

 4992 C PURPOSE - TO COMPUTE OCEAN SURFACE HEAT FLUXES INTO A 

 4993 C PARTICULAR CELL 

 4994 C VARIABLES - 

 4995 C CSENS = COEFFICIENT FOR SENSIBLE HEAT GAIN (SEE HEAT1) 

 4996 C EA,ES = SATURATION VAPOR PRESSURE (PASCALS) 

 4997 C EPSLON = RATIO OF MOLECULAR WEIGHTS OF VAPOR AND DRY AIR 

 4998 C (O2 + H2 + N2) 

 4999 C FTSURF = SURFACE LAYER HEATING (DEG C) 

 5000 C PA = ATMOSPHERIC PRESSURE (PASCALS) 

 5001 C QI,QA,QB,QE,QS = heat inputs (Watts/m**2/K**4) 

 5002 C RELHUM = RELATIVE HUMIDITY (0.0 < RELHUM < 1.0) 

 5003 C SB = STEFAN-BOLTZMAN CONSTANT (Watt/meter**2/K**4) 

 5004 C TAIRK = AIR TEMPERATURE (K) 

 5005 C T0 = AIR TEMPERATURE AT SEA SURFACE (K) 

 5006 C TRAD = CHANGE IN TEMPERATURE OVER ONE TIMESTEP (DEG C) 

 5007 C TW = WATER TEMPERATURE AT NEAR-SURFACE (K) 

 5008 INCLUDE 'COMM20.FOR' 

 5009 DIMENSION TRAD(LSIZE) 

 5010 DATA IP/0/ 

 5011 T2KEL(TEMP)=TEMP+273.*(.5-SIGN(.5,TEMP-200.)) 

 5012 IP1=0 
49

 5013 IF(NPRMN.EQ.0)GOTO 100 

 5014 DO J=1,NPRMN 

 5015 IF(IP.EQ.1.AND.IPRNT1.EQ.1.AND.N+1000*M.EQ.IPRMN(J))IP1=1 

 5016 ENDDO 

 5017 100 CONTINUE 

 5018 C SET CONSTANT 

 5019 A=MIN0(1,IHEAT) 

 5020 C WATER SURFACE TEMP (C) 

 5021 TWS=T2KEL(.5*(T(1,N,M)+T(2,N,M))) 

 5022 C SET AIR TEMP JUST ABOVE SURFACE (K) EQUAL TO WATER TEMP 

 5023 FBETA=.9 

 5024 T0=FBETA*TWS+(1.-FBETA)*TAIRK 

 5025 c BULK TRANSFER COEFFICIENT 

 5026 W10=SQRT(WX(N,M)**2+WY(N,M)**2) 

 5027 CDRAGW=0.0025+SIGN(.0015,TWS-TAIRK) ! HIGHER IF UNSTABLE (TW > TA

 5028 CSENS=RHOA*CDRGAW*CPAIR*AMAX1(W10,0.2) 

 5029 CEVP1=ALV*RHOA*CDRGAW*EPSLON*AMAX1(W10,0.2) 

 5030 c print 

 5031 IF(IP1.EQ.1)WRITE(ISCR,105)UT,N,M 

 5032 105 FORMAT(/,1X,'HEATZ: UT=',F10.4,' N,M=',2I4) 

 5033 IF(IP1.EQ.1)WRITE(ISCR,110)TAIRK,TWS,T0,W10 

 5034 110 FORMAT(1X,'TAIRK,TWS,T0 (K)=',3F8.2,' W10=',F6.2) 

 5035 C SATURATION VAPOR PRESSURE AT AIR-WATER INTERFACE 

 5036 ES=611.0*10.**(7.5*(T0-273.16)/(T0-35.86)) 

 5037 EA=RELHUM*ES 

 5038 C SOLAR SHORT-WAVE INWARD (Watt/m**2) 

 5039 QI=0.0 

 5040 IF(COSZ.GT.0.0)QI=A*AMAX1(0.0,CSOL1/(CSOL2+CSOL3*EA)) 

 5041 C WATER BLACK BODY INWARD 

 5042 QB=A*(-.97)*SB*(TWS)**4 

 5043 C SENSIBLE HEAT GAIN 

 5044 QS=A*CSENS*(TAIRK-TWS) 

 5045 C EVAPORATIVE HEAT GAIN 

 5046 QE=A*CEVP1*(CEVP2-EA/(PA-(1.-EPSLON)*EA)) 

 5047 QSUM=QA+QS+QE+QB 

 5048 IF(IP1.EQ.1)WRITE(ISCR,130)QB,QS,QA,QE,QSUM 

 5049 130 FORMAT(1x,'QB,QS,QA,QE,QSUM=',5E10.3) 

 5050 C TOTALS: FQ, FS HAVE UNITS (DEG C)*M/S CTOT=1./(RHOW*CWATER) 

 5051 FQ=CTOT*QSUM 

 5052 C SURFACE LAYER HEATING: UNITS=DEG C 

 5053 FTSURF=FQ*DTI/((D(N,M)+SE(N,M))*HALFDQ) 

 5054 IF(IP1.EQ.1)WRITE(ISCR,*)'FTSURF=',FTSURF 

 5055 C INTERNAL SOLAR HEATING: TRAD units= deg C 

 5056 FS=CTOT*QI ! deg C x m/s 

 5057 H=D(N,M)+SE(N,M) 

 5058 IF(IP1.EQ.1)WRITE(ISCR,*)'FS=',FS,' H=',H 

 5059 FD10=2.30/D10PCT 

 5060 DO 220 L=1,LBOT 

 5061 TRAD(L)=0. 

 5062 ZTOP=H*AMIN1(0.0,DQ*FLOAT(1-L)+HALFDQ) 

 5063 IF(ZTOP.LT.-2.*D10PCT)GOTO 220 

 5064 ZBOT=H*AMAX1(-1.,DQ*FLOAT(1-L)-HALFDQ) 

 5065 TRAD(L)=FS*DTI*(EXP(FD10*ZTOP)-EXP(FD10*ZBOT))/(ZTOP-ZBOT) 

 5066 IF(IP1.EQ.1)WRITE(ISCR,150)L,ZTOP,TRAD(L) 

 5067 150 FORMAT(1X,'L=',I2,' ZTOP=',F6.2,' TRAD=',E10.4) 

 5068 220 CONTINUE 

 5069 RETURN 

 5070 END 

 5071 C 

 5072 C----------------------------------------------------------------------- 

 5073 C 

 5074 SUBROUTINE SETSTP 

 5075 

 5076 C JUNE 1985 K. W. HESS MEAD VAX 11/750 

 5077 C PURPOSE - SET UP THE INITIAL FIELDS OF SALINITY AND 

 5078 C TEMPERATURE BY INTERPOLATING FROM THE BOUNDARY 

 5079 C CONDITIONS. SET INITIAL HORIZONTAL PRESSURE GRADIENTS 

 5080 C VARIABLES - 

 5081 C ICS = INDEX FOR READING INITIAL CONDITIONS 

 5082 C (0=N0, 1=YES) 

 5083 C NBCELL = TOTAL NUMBER OF BOUNDARY GRIDS (RIV + OCEAN) 

 5084 INCLUDE 'COMM20.FOR' 

 5085 DIMENSION NO(NM2SIZ),MO(NM2SIZ),R(NM2SIZ),SBNDP(LSIZE,NM2SIZ) 

 5086 C SET BOUNDARY STATE 

 5087 CALL BSTATE 

 5088 IF(ICS.EQ.1)GOTO 310 

 5089 C SET DEFAULT VALUES 

 5090 DO 100 L=1,LBOT 

 5091 DO 100 N=1,NM2SIZ 

 5092 SBNDP(L,N)=SBND(L,N) 

 5093 IF(N.GT.NBCELO.AND.KONCEN.EQ.2)SBNDP(L,N)=SAL0 

 5094 IF(N.GT.NBCELO.AND.MOD(KONCEN+1,2).EQ.0)SBNDP(L,N)=5. 

 5095 100 continue 

 5096 C SET OCEANIC BOUNDARY VALUES 

 5097 J=0 

 5098 IF(NUMOBC.LE.0)GOTO 130 

 5099 DO 120 I=1,NUMOBC 

 5100 DO 120 N=NB1(I),NB2(I) 

 5101 DO 120 M=MB1(I),MB2(I) 

 5102 J=J+1 

 5103 MO(J)=M 

 5104 NO(J)=N 

 5105 DO 120 L=1,LBOT 

 5106 S(L,N,M)=SBNDP(L,J) 

 5107 T(L,N,M)=TBND(L,J) 

 5108 120 CONTINUE 

 5109 C SET RIVER BOUNDARY VALUES 

 5110 130 IF(NUMRIV.LE.0)GOTO 200 

 5111 DO 140 I=1,NUMRIV 

 5112 DO 140 M=MR1(I),MR2(I) 

 5113 DO 140 N=NR1(I),NR2(I) 

 5114 J=J+1 

 5115 MO(J)=M 

 5116 NO(J)=N 

 5117 DO 140 L=1,LBOT 

 5118 S(L,N,M)=SBNDP(L,J) 

 5119 T(L,N,M)=TBND(L,J) 

 5120 140 CONTINUE 

 5121 C LOOP THRU THE INTERIOR COMPUTATIONAL GRIDS 

 5122 200 DO 300 M=1,MMAX 

 5123 DO 300 N=1,NMAX 

 5124 IF(IFIELD(N,M).LT.10.OR.IFIELD(N,M).GE.10*(KOCNBC))GOTO 300 

 5125 IF(D(N,M).LE.0.0)WRITE(ISCR,240)N,M 

 5126 240 FORMAT(1X,'*** SETUP: NO DEPTH AT N=',I3,', M=',I3) 

 5127 C FIND RADAII TO BOUNDARY DATUM, AND SUM OF RADAII 

 5128 RSUM=0.0 

 5129 DO 250 I=1,NBCEL 

 5130 R(I)=1./(0.25+(FLOAT((N-NO(I))**2)+FLOAT((M-MO(I))**2))) 

 5131 250 RSUM=RSUM+R(I) 

 5132 255 RINV=1./RSUM 

 5133 DO 270 L=1,LBOT 

 5134 S(L,N,M)=0.0 

 5135 T(L,N,M)=0.0 

 5136 DO 260 I=1,NBCEL 

 5137 S(L,N,M)=S(L,N,M)+(R(I)*RINV)*SBNDP(L,I) 

 5138 T(L,N,M)=T(L,N,M)+(R(I)*RINV)*TBND(L,I) 

 5139 260 CONTINUE 

 5140 270 CONTINUE 

 5141 300 CONTINUE 

 5142 310 CONTINUE 

 5143 RETURN 

 5144 END 

 5145 c======================================================================= 

 5146 C COMMS.FOR - COMMON BLOCKS FOR PROGRAM MECCA 

 5147 PARAMETER (NSIZE = 34, MSIZE= 55, LSIZE= 10, NMSIZE=NSIZE*MSIZE, 

 5148 1 LNMSIZ=LSIZE*NSIZE*MSIZE, NPMSIZ=NSIZE+MSIZE+2, NM2SIZ=2*(NSIZE+ 

 5149 2 MSIZE), NDTID2=5, NDRIV2=10, NDOCN2=LSIZE, NDMET2=4) 

 5150 C MODEL CONSTANTS 

 5151 COMMON/CONS1/AG,OMEGA,PI,RAD,E,VONKAR,CRICH(8),RIMIN,RIMAX,CR0, 

 5152 1 IEXTRN,COR,NCOR,MCOR,DFDN,DFDM,BSNLAT,BSNANG,NONLIN,DL,CDRGWB, 

 5153 2 FCOR0,VERS,FEDGE(NSIZE,MSIZE),IHDSE,CDWB1,CDWB2,RAMPG,IGRADP, 

 5154 3 RAMPT,RAMPW,IBETAA,IBETAP,IBETAH,RHOBAR,INTER,SAL0,TMP0,CS0,CS1, 

 5155 4 CST,CT1,CT2,ISTOP,ICS,KTEST,NDAYMO(12),IHVISC,AH00,AH0,CAH,RHOA, 

 5156 5 RHOW,DHAH,DTE,DTI,ISPLIT,NSTI,NSTIT,NSTE,NSTET,NSTIMX,DTAU1,DTAU2 

 5157 C OUTPUT FORMAT VARIABLES 

 5158 PARAMETER (NDPRN=20, NDSLC1=5, NDSLC2=20, NDGPH=20) 

 5159 CHARACTER*10 CTITLE,PTITLE 

 5160 REAL*8 YT 

 5161 COMMON/TIME1/NST0,UT,UT0,UT1,HR,HR0,HR1,IHR,YT,IYEAR,MONTH, 

 5162 1 IDAY,IHOUR,IMIN,YEAR,YEAR0,YEAR1,CUMDAY,NMAX,MMAX,NCELL,DMAX, 

 5163 2 NEGS,ICHECK,ICOR,IBOTV,ITOPV,IVISC,NVISC,IPRNT1,JPRNT(15), 

 5164 3 KPRNT1,KPRNT2,HRMAX,HROUT,HROUT0,NPRMN,IPRMN(NDPRN), 

 5165 4 CTITLE(8),ISLICE,JSLICE(NDSLC1),NSLICE(NDSLC2,NDSLC1),MSLICE( 

 5166 5 NDSLC2,NDSLC1),ISTART,NGPMAX,IGPH,NSTGPH,IGPHOP,HRSAVE, 

 5167 6 LGPH(NDGPH),MGPH(NDGPH),NGPH(NDGPH),ITYP(NDGPH),PTITLE(25) 

 5168 C MODEL GRID AND GEOGRAPHY VARIABLES 

 5169 COMMON/GEOG1/BSNLON,CON2M,HMSL,NUMRIV,NCOL1,IFIELD(NSIZE,MSIZE), 

 5170 1 ICOL(5,NM2SIZ),IROW(5,NM2SIZ),NCOL,NROW,NAB(NM2SIZ),DMIN,KOCNBC, 

 5171 2 KRIVBC,IBARR,GRX(LSIZE),GRY(LSIZE),AREA(NSIZE,MSIZE), 

 5172 3 BX(NSIZE,MSIZE),BY(NSIZE,MSIZE),THETA1(NSIZE,MSIZE), 

 5173 4 THETA2(NSIZE,MSIZE),THETA3(NSIZE,MSIZE),NUMBXY,Z0 

 5174 C TIDE, MET, AND RIVER VARIABLES 

 5175 COMMON/TIDES1/NSIGT,IENDTD,YTID(2),DTID(2),TDLEV(2,NDTID2), 

 5176 1 IENDWN,WX(NSIZE,MSIZE),WY(NSIZE,MSIZE),DPADX,DPADY, 

 5177 2 FX(2,NSIZE,MSIZE),FY(2,NSIZE,MSIZE),DENRAT,CDR1,CDR2,TAIRK,TAIRC, 

 5178 3 TSX(NSIZE,MSIZE),TSY(NSIZE,MSIZE),IHEAT,NSIGW,DWND(2),YWND(2), 

 5179 4 PA,CLOUD,RELHUM,NSIGM,DMET(2),YMET(2),VMET(2,NDMET2),IENDMT, 

 5180 5 NSIGR,YRIV(2),DRIV(2),QRIV(2,NDRIV2),RATE(NDRIV2),ISETR(NDRIV2), 

 5181 6 IENDRV,MR1(NDRIV2),MR2(NDRIV2),NR1(NDRIV2),NR2(NDRIV2),IENDRT, 

 5182 7 ITPR(NDRIV2),JTPR(NDRIV2),NSIGRT,YRVT(2),DRVT(2),TRIV(2,NDRIV2) 

 5183 C OCEAN BOUNDARY CONDITIONS 

 5184 COMMON/FLAG1/NUMOBC,MB1(NDOCN2),MB2(NDOCN2),NB1(NDOCN2),NB2( 

 5185 1 NDOCN2),ITPO(NDOCN2),JTPO(NDOCN2),ISET1(NDOCN2),ISET2(NDOCN2), 

 5186 2 NSIGS,YSAL(2),DSAL(2),SALOCN(2,NDOCN2),IENDSO,NSIGTO,YOTP(2), 

 5187 3 DOTP(2),TMPOCN(2,NDOCN2),IENDTO,NBCEL,NBCELO,SBND(LSIZE,NM2SIZ), 

 5188 4 TBND(LSIZE,NM2SIZ),NSTINF(LSIZE,NM2SIZ),ITPO2(NDOCN2) 

 5189 C INTERNAL MODE (3-D) VARIABLES 

 5190 COMMON/TRID1/LAYRS,LBOT,DQ,HALFDQ,TWODQ,AH3(LSIZE,NSIZE,MSIZE), 

 5191 1 U(LSIZE,NSIZE,MSIZE),V(LSIZE,NSIZE,MSIZE),UE(NSIZE,MSIZE), 

 5192 2 VE(NSIZE,MSIZE),AV(LSIZE,NSIZE,MSIZE),ISIDE,AV0,AV00,WC(LSIZE), 

 5193 3 W(LSIZE,NSIZE,MSIZE),DV(LSIZE,NSIZE,MSIZE),DV0,DV00,CDRGWS, 

 5194 4 RI(LSIZE,NSIZE,MSIZE),AH(NSIZE,MSIZE),AHC(NSIZE,MSIZE),THETSU( 

 5195 5 NSIZE,MSIZE),THETSV(NSIZE,MSIZE) 

 5196 C EXTERNAL MODE VARIABLES 

 5197 COMMON/VELS1/UH(NSIZE,MSIZE),UHP(NSIZE,MSIZE),VH(NSIZE,MSIZE), 

 5198 1 VHP(NSIZE,MSIZE),D(NSIZE,MSIZE),SE(NSIZE,MSIZE),SEP(NSIZE,MSIZE), 

 5199 2 SEPP(NSIZE,MSIZE),FA(NPMSIZ),FB(NPMSIZ),GA(NPMSIZ),GB(NPMSIZ), 

 5200 3 ANB,ANC,SOLD(NSIZE,MSIZE),UHOLD(NSIZE,MSIZE),VHOLD(NSIZE,MSIZE), 

 5201 4 PHI(NSIZE,MSIZE),TBX(NSIZE,MSIZE),TBY(NSIZE,MSIZE),ANA 

 5202 C CONCENTRATION (SALINITY AND TEMPERATURE) VARIABLES 

 5203 COMMON/CONC1/KONCEN,ICPOS,ICOUPL,CI(LSIZE),RVERT,HRCONC, 

 5204 1 S(LSIZE,NSIZE,MSIZE),MFLUX(NSIZE,MSIZE),NFLUX(NSIZE,MSIZE), 

 5205 2 GSTARX(NSIZE,MSIZE),GSTARY(NSIZE,MSIZE),HRCON1,HRCON2,T(LSIZE, 

 5206 3 NSIZE,MSIZE),COSZ,CSOL1,CSOL2,CSOL3,SB,CSENS,CEVP1,CEVP2,D10PCT, 

 5207 4 EPSLON,CTOT,QSUM,QA,QI,QB,QS,QE,EA,ES,SOLAR,ALB,CWATER,CPAIR,ALV 

 5208 C FILE HANDELING 

 5209 CHARACTER*40 FCON,FGEO,FINIT,FPRINT,FGRAPH,FMED 

 5210 COMMON/FILE1/FCON,FGEO,FINIT,FPRINT,FGRAPH,FMED,ISCR,LUKB,IO, 

 5211 2 LUGRF,LUCON,LUMED,LUTID,LUWND,LURIV,LUSAL,LUOCT,LUMET,LURVT