Subroutines
HDMT2T: Executes the full hydrodynamic and mass transport time integration using a two time level scheme
Calculate Vertical Viscosity and Diffusivity
CALAVB.f90: Subroutine CALAV calculates vertical viscosity and diffusivity using Galerpin Et Al's modification of the MELLOR-YAMADA Model
CALBUOY.f90: Calculates the buoyancy using Mellor's approximation to the UNESCO Equation of State.
CALCONC.f90: Calculates the concentration of dissolved and suspended constituents, including salinity, temperature, dye and suspended sediment. CALCSER.for: Updates the time variable salinity, temperature, dye, sediment, and shell fish larve CALDIFF : Calculates the horizontal diffusive transport of dissolved or suspended constituent CALEBI: Calculates the external buoyancy integrals CALEXP: Calculates explicit momentum equation terms CALEXP2T: Calculates explicit momentum equation terms using a two time level scheme CALFQC: Calculates mass sources and sinks associated with constant and time series inflows and outflow; control structure inflows and outflows; withdrawal and return structure outflows; and embel channel inflows and outflows. CALHDMF.f90: Calculates the horizontal viscosity and diffusive momentum fluxes. The viscosity, AH is calculated using SMAGORINSKY'S sub grid formulation plus a constant AHO CALHEAT.f90: Takes information from the atmospheric boundary file and wind forcing file and calculates the net heat flux across the water surface boundary. The heat flux is then used to update the water temperature either in the surface cells, or distributed across the cells in the vertical and into the bottom. CALHTA.for: Performs a harmonic analysis for the M2 tide over two tidal cycles. CALIM2T.for: Calculates implicit momentum equation Coriolis and curvature terms for 1/2 step predictor CALMMT.for: Calculates the mean mass transport field. CALPNHS.for: Calculates quasi-non hydrostatic pressure CALPSER.for: Updates the variable surface elevation boundary conditions CALPUV2C.f90: Calculates the external solution for P, UHDYE, and VHDXE, for free surface flows for the 2TL solution. CALPUV9.for: Calculates the external solution for P, UHDYE, and VHDXE, for free surface flows for the 3TL solution. CALSED.f90: Calculates cohesive sediment settling, deposition and resuspension and is called for SSEDTOX. CALSFT.for: Calculates the transport of the shell fish larvae at time level (n+1) CALSND.f90: Calculates non cohesive sediment settling, deposition and resuspension and is called for SSEDTOX. CALSTEPD.f90: Subroutine CALSTEP estimate the current maximum time step size form linear stability criteria and a factor of safety. |
CALTBXY.f90: Calculates bottom friction or drag coefficients in quadratic law form referenced to near bottom or depth averaged horizontal velocities for vegetation resistance in depth integrated flow. the coefficient represents bottom and water column vegetation resistance.
CALTOX.for: Calculates toxic contaminant particulate fractions
CALTOXB.for: Calculates contaminant transport within the sediment bed, including flux of contaminants from the top bed layer to the water column.
CALTRAN.f90: Calculates the advective transport of dissolved or suspended constituent M leading to a new value at time level (N+1). the value of ISTL indicates the number of time levels in the step.
CALTSXY.f90: updates the time variable surface wind stress
CALUVW.f90: Calculates the internal solution at time level (N+1).
CALVEGSER.for: Calculates time variable vegetation resistance parameters
CALWQC.f90: Calculates the concentration of dissolved and suspended water quality constituents at time level (N+1). Called only on odd three time level steps.
CBALEV.for: Calculates global volume, mass, momentum, and energy balances
CBALEV1.for : Initialize volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
CBALEV2.for: Accumulates fluxes across open boundaries
CBALEV3.for: Accumulate internal sources and sinks
CBALEV4.for: Calculates momentum and energy dissipation
CBALEV5.for: Calaculate ending volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
CBALOD.for: Subroutines CBALOD calculate global volume, mass, momentum and energy balances
CBALOD1.for: Initialize volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes
CBALOD2.for: Accumulate fluxes across open boundaries
CBALOD3.for: Accumulate internal sources and sinks
CBALOD4.for: Calculate momentum and energy dissipation
CBALOD5.for: Calculate ending volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
The different between CBALEV and CBALOD is that in CBALEV the parameters end with letter "E" and in CBALOD the parameters end with letter "O".
CELLMAP.for: Generates cell mappings
CELLMASK.for: Concerts land cells to water cells by masking variables. Depth in the masked cells should be input at the end of the
DXDY.inp file.
CEQICM.for: Subroutine for interfacing CE-QUAL-ICM Model
CONGRAD.F90: CONGRAD Solves the external mode by a conjugate gradient scheme.
CONGRADC.for: CONGRAD Solves the external mode by a conjugate gradient scheme
CONSTRAN.for: Calculates the advective transport of dissolved or suspended constituent M leading to a new value at time level (N+1).
DRIFTER.f90: Is a lagrangian particle tracking module for the dynamic solution version of EFDC. This module completely replaces the
previous versions of particle tracking in EFDC.
DSTIME.f90: DSTIME returns back the number of seconds since some event.
DUMP.for: Writes full field dumps of model variables at specified time intervals.
EEXPOUT.f90: Writes binary output files:
** SUBROUTINE EEXPOUT WRITES BINARY OUTPUT FILES:
! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS
! ** EE_BED - SEDIMENT BED LAYER INFORMATION
! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN
! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION
! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO
! ** EFDC_EXPLORER FOR DISPLAY
! ** EE_SEDZLJ - SEDIMENT BED DATA FOR SEDZLJ SUB-MODEL
EFDC.FOR: Main Program
CALTOX.for: Calculates toxic contaminant particulate fractions
CALTOXB.for: Calculates contaminant transport within the sediment bed, including flux of contaminants from the top bed layer to the water column.
CALTRAN.f90: Calculates the advective transport of dissolved or suspended constituent M leading to a new value at time level (N+1). the value of ISTL indicates the number of time levels in the step.
CALTSXY.f90: updates the time variable surface wind stress
CALUVW.f90: Calculates the internal solution at time level (N+1).
CALVEGSER.for: Calculates time variable vegetation resistance parameters
CALWQC.f90: Calculates the concentration of dissolved and suspended water quality constituents at time level (N+1). Called only on odd three time level steps.
CBALEV.for: Calculates global volume, mass, momentum, and energy balances
CBALEV1.for : Initialize volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
CBALEV2.for: Accumulates fluxes across open boundaries
CBALEV3.for: Accumulate internal sources and sinks
CBALEV4.for: Calculates momentum and energy dissipation
CBALEV5.for: Calaculate ending volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
CBALOD.for: Subroutines CBALOD calculate global volume, mass, momentum and energy balances
CBALOD1.for: Initialize volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes
CBALOD2.for: Accumulate fluxes across open boundaries
CBALOD3.for: Accumulate internal sources and sinks
CBALOD4.for: Calculate momentum and energy dissipation
CBALOD5.for: Calculate ending volume, salt mass, dye mass, momentum, kinetic energy and potential energy, and associated fluxes.
The different between CBALEV and CBALOD is that in CBALEV the parameters end with letter "E" and in CBALOD the parameters end with letter "O".
CELLMAP.for: Generates cell mappings
CELLMASK.for: Concerts land cells to water cells by masking variables. Depth in the masked cells should be input at the end of the
DXDY.inp file.
CEQICM.for: Subroutine for interfacing CE-QUAL-ICM Model
CONGRAD.F90: CONGRAD Solves the external mode by a conjugate gradient scheme.
CONGRADC.for: CONGRAD Solves the external mode by a conjugate gradient scheme
CONSTRAN.for: Calculates the advective transport of dissolved or suspended constituent M leading to a new value at time level (N+1).
DRIFTER.f90: Is a lagrangian particle tracking module for the dynamic solution version of EFDC. This module completely replaces the
previous versions of particle tracking in EFDC.
DSTIME.f90: DSTIME returns back the number of seconds since some event.
DUMP.for: Writes full field dumps of model variables at specified time intervals.
EEXPOUT.f90: Writes binary output files:
** SUBROUTINE EEXPOUT WRITES BINARY OUTPUT FILES:
! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS
! ** EE_BED - SEDIMENT BED LAYER INFORMATION
! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN
! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION
! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO
! ** EFDC_EXPLORER FOR DISPLAY
! ** EE_SEDZLJ - SEDIMENT BED DATA FOR SEDZLJ SUB-MODEL
EFDC.FOR: Main Program
Found Structure @ 0
SUBROUTINE ACON(ITVAL)
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NJELM,NATDM,ITVAL,NT,NS,NX,NZ,NZP
REAL::WTNZP,WTNZ
PARAMETER (NJELM=2,NATDM=1)
Found Structure @ 79
SUBROUTINE AINIT
C
C CHANGE RECORD
C ADDED TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS
C ADDED TRANSPORT BYPASS MASK, LMASKDRY FOR DRY CELLS
C MODIFIED DEFINITION OF CHANLEN IN INITIALIZATION RATHER THAN
C IN SUBS CALTBXY AND CALPUV2C AND CALPUV9C
C
C ALL ZEROING OF ARRAYS MOVED TO ZERO
C
Found Structure @ 441
SUBROUTINE BAL2T1
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 619
SUBROUTINE BAL2T2
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 772
SUBROUTINE BAL2T3A
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C MODIFIED SND MASS BALANCE WITH RESPECT TO BED LOAD OUTFLOW
C ADDED QDWASTE TO WATER MASS BALANCE
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
Found Structure @ 1170
SUBROUTINE BAL2T3B(IBALSTDT)
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C MODIFIED SND MASS BALANCE WITH RESPECT TO BED LOAD OUTFLOW
C ADDED QDWASTE TO WATER MASS BALANCE
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
Found Structure @ 1294
SUBROUTINE BAL2T4
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
Found Structure @ 1336
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE BAL2T5
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 2148
SUBROUTINE BEDINIT
C
C ** SUBROUTINE BEDINIT INITIALIZES SEDIMENT AND TOXIC VARIABLES
C ** IT SEDIMENT BED FOR HOT AND COLD START CONDITIONS
C CHANGE RECORD
C ADDED ADDITIONAL DIAGNOSTIC OUTPUT
C MOVED TOXIC INITIALIZATIONS FROM SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 3620
SUBROUTINE BEDLOAD(NX,NS)
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,NSB,LUTMP,LDTMP,LS,LN,NX,NS
Found Structure @ 4135
SUBROUTINE BEDPLTH
C
C CHANGE RECORD
C 11/14/2001 JOHN HAMRIC 11/14/2001 JOHN HAMRIC
C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY
C ** SUBROUTINE WRITES SEDIMENT BED PROPERTIES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,K,NX,NS,NSXD,KTMP
Found Structure @ 4352
SUBROUTINE BUDGET1
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,NS
IF(NBUD.GT.1) RETURN
Found Structure @ 4478
SUBROUTINE BUDGET2
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::LS,NT,LL,K,L,LN
C
Found Structure @ 4574
SUBROUTINE BUDGET3
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,NS,NWR,NCTL,ID,JD,LD,KU,KD,M,IU,JU,LU
Found Structure @ 4822
SUBROUTINE BUDGET5
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NS,L,K
REAL::SEDBTMP1,SEDBTMP,SFLXTMP,BSEDERR,SSEDOUT,BSEDOUT,SSEDERE
Found Structure @ 5077
SUBROUTINE CALAVB (ISTL_)
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
C
USE GLOBAL
Found Structure @ 5254
SUBROUTINE CALAVB2 (ISTL_)
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C
USE GLOBAL
Found Structure @ 5420
SUBROUTINE CALAVBOLD (ISTL_)
C
C *** OLD STANDARD
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
Found Structure @ 5589
SUBROUTINE CALBAL1
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
IF(NBAL.GT.1) RETURN
Found Structure @ 5648
SUBROUTINE CALBAL2
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::LL,K,LS,L,LN
C
Found Structure @ 5729
SUBROUTINE CALBAL3
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,K,LL,NS,NQSTMP,NCSTMP,NCTL,IU,JU,LU
Found Structure @ 5897
SUBROUTINE CALBAL4
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
REAL::DUTMP,DVTMP
Found Structure @ 5933
SUBROUTINE CALBAL5
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
REAL::ENEEND,ENEOUT,VOLBMO,SALBMO,DYEBMO,UMOBMO,VMOBMO,ENEBMO
REAL::VOLERR,SALERR,DYEERR,UMOERR,VMOERR,ENEERR,RVERDE,RSERDE
Found Structure @ 6139
SUBROUTINE CALBED
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVE SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IFLAG,LUTMP,NS,NSB,KK,NX,KBTM1
Found Structure @ 6967
SUBROUTINE CALBED9
C
C CHANGE RECORD
C ** SUBROUTINE CALBED9 CALCULATES CALCULATES BED CONSOLIDATION
C WHERE A DIFFERENT TYPE OF CONSOLIDATION CAN BE USED FOR EACH
C CELL
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IFLAG,KK,NSB,LUTMP,NS,NX,KBTM1
Found Structure @ 7920
SUBROUTINE CALBLAY
C
C CHANGE RECORD
C ** SUBROUTINE CALBLAY REMOVES OR ADDS LAYERS TO THE SEDIMENT BED
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,NS,L,NT,NX
REAL::TMPBOT2,TMPTOP1,TMPTOP2,TMPVAL,HBEDMXT,HOLDTOP,FKBTP
Found Structure @ 8550
SUBROUTINE CALBUOY
C
C CHANGE RECORD
C ** CALBUOY CALCULATES THE BUOYANCY USING MELLOR'S APPROXIMATION
C ** TO THE UNESCO EQUATION OF STATE (MELLOR, G.L., J. ATM AND OCEAN
C ** TECH, VOL 8, P 609)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NS,K,L
Found Structure @ 8693
SUBROUTINE CALCONC (ISTL_,IS2TL_)
C
C CHANGE RECORD
C MODIFIED CALLS TO CALBAL AND BUDGET SUBROUTINES
C ADDED CALLS TO BAL2T2, BAL2T3
C ** SUBROUTINE CALCULATES THE CONCENTRATION OF DISSOLVED AND
C ** SUSPENDED CONSTITUTENTS, INCLUDING SALINITY, TEMPERATURE, DYE AND
C ** AND SUSPENDED SEDIMENT AT TIME LEVEL (N+1). THE VALUE OF ISTL
C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
Found Structure @ 9692
C
SUBROUTINE CALCSER (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SALINITY, TEMPERATURE
C ** DYE, SEDIMENT, AND SHELL FISH LARVAE
C ** BOUNDARY CONDITIONS AND INFLOW CONCENTRATIONS
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 9975
SUBROUTINE CALDIFF (ISTL_,M,CON1)
C
C CHANGE RECORD
C ** SUBROUTINE CALDIFF CALCULATES THE HORIZONTAL DIFFUSIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A REVISEDED VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL
C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 10003
SUBROUTINE CALDISP2
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,KK,KT,L,LN
REAL::CLTMP,CTMP,AMCPT,AMSPT,UAVG,VAVG,CUTMP,CMTMP
REAL::CCUU,CCVV,CCUV,CCVU
Found Structure @ 10308
SUBROUTINE CALDISP3
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,KK,L,LS,KT,LN
REAL::CLTMP,DDD,CMTMP,DXXTMP,WTX,DXXWEST,DXXEAST
REAL::DXXSOUT,DXXNORT,WTY,DYXWEST,DYXEAST,DYXSOUT,DYXNORT
Found Structure @ 10786
SUBROUTINE CALEBI
C
C CHANGE RECORD
C ** CALEBI CALCULATES THE EXTERNAL BUOYANCY INTEGRALS
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IPMC,LLCM
REAL::EPSILON,DBK,DZCBK
Found Structure @ 10834
SUBROUTINE CALEXP (ISTL_)
C
C ** SUBROUTINE CALEXP CALCULATES EXPLICIT MOMENTUM EQUATION TERMS
C ** THIS SUBROUTINE IS CURRENT PRODUCTION VERSION
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
C
C----------------------------------------------------------------------C
Found Structure @ 11825
SUBROUTINE CALEXP2T
C
C ** SUBROUTINE CALEXP2T CALCULATES EXPLICIT MOMENTUM EQUATION TERMS
C ** USING A TWO TIME LEVEL SCHEME
C CHANGE RECORD
C ADDED BODY FORCES FBODYFX AND FBODYFY TO EXTERNAL MOMENTUM EQUATIONS
C CORRECTED ORIENTATION OF MOMENTUM FLUXES FROM SINKS AND SOURCE
C CORRECTED 2 LAYER (KC=-2) CURVATURE ACCELERATION CORRECTION
C ADDED ICK2COR,CK2UUM,CK2VVM,CK2UVM,CK2UUC,CK2VVC,CK2UVC,CK2FCX,
C CK2FCY TO GENERALIZE TWO LAYER MOMENTUM FLUX AND CURVATURE
C ACCELERATION CORRECTION
Found Structure @ 13057
SUBROUTINE CALFQC(ISTL_,IS2TL_,MVAR,MO,CON,CON1,FQCPAD,QSUMPAD,
& QSUMNAD)
C
C CHANGE RECORD
C ** SUBROUTINE CALFQC CALCULATES MASS SOURCES AND SINKS ASSOCIATED
C ** WITH CONSTANT AND TIME SERIES INFLOWS AND OUTFLOWS; CONTROL
C ** STRUCTURE INFLOWS AND OUTLOWS; WITHDRAWAL AND RETURN STRUCTURE
C ** OUTFLOWS; AND EMBEDED CHANNEL INFLOWS AND OUTFLOWS
C
USE GLOBAL
Found Structure @ 14189
SUBROUTINE CALHDMF
C
C *** CALDMF CALCULATES THE HORIZONTAL VISCOSITY AND
C *** DIFFUSIVE MOMENTUM FLUXES. THE VISCOSITY, AH IS CALCULATED USING
C *** SMAGORINSKY'S SUBGRID SCALE FORMULATION PLUS A CONSTANT AHO
C
C *** ONLY VALID FOR ISHDMF.GE.1
C
C CHANGE RECORD
C REWRITTEN BY PAUL M. CRAIG NOV/DEC 2004
Found Structure @ 14495
SUBROUTINE CALHEAT(ISTL_)
C
C Subroutine CALHEAT takes the information from the atmospheric boundary
C file and the wind forcing file and calculates the net heat flux across
C the water surface boundary. The heat flux is then used to update the
C water temperature either in the surface cells, or distributed across
C the cells in the vertical and into the bottom. The subroutine has
C three options these are:
C
C ISOPT(2)=1: Full surface and internal heat transfer calculation
C using meteorologic data from input stream.
Found Structure @ 15052
************************************************************************
** S U B R O U T I N E H E A T E X C H A N G E **
** **
** FROM CE-QUAL-W2 (VER 3.1) **
** **
************************************************************************
SUBROUTINE HEAT_EXCHANGE
USE GLOBAL
Found Structure @ 15215
SUBROUTINE CALHTA
C
C CHANGE RECORD
C ** SUBROUTINE CALHTA PERFORMS A HARMONIC ANALYSIS FOR THE M2 TIDE
C ** OVER TWO TIDAL CYCLES
C
USE GLOBAL
CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE11,TITLE12
C
C ** INITIALIZE ON FIRST ENTRY FOR CURRENT ANALYSIS INTERVAL
Found Structure @ 15462
SUBROUTINE CALIMP2T
C
C ** SUBROUTINE CALEXP CALCULATES IMPLICIT MOMENTUM EQUATION
C ** CORIOLIS AND CURVATURE TERMS FOR 1/2 STEP PREDICTOR
C CHANGE RECORD
C
USE GLOBAL
IF(ISDYNSTP.EQ.0)THEN
DELT=DT
DELTD2=0.5*DT
Found Structure @ 15993
SUBROUTINE CALMMT
C
C CHANGE RECORD
C ** SUBROUTINE CALMMTF CALCULATES THE MEAN MASS TRANSPORT FIELD
C
USE GLOBAL
C
LOGICAL INITIALIZE
DATA INITIALIZE/.TRUE./
C
Found Structure @ 16982
SUBROUTINE CALPNHS
C
C CHANGE RECORD
C ** SUBROUTINE CALPNHS CALCULATES QUASI-NONHYDROSTATIC PRESSURE
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PNHYDSS
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FWJET
REAL::QWRABS
Found Structure @ 17179
SUBROUTINE CALPSER (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SURFACE ELEVATION
C ** BOUNDARY CONDITIONS
C
USE GLOBAL
PSERT(0)=0.
DO NS=1,NPSER
IF(ISDYNSTP.EQ.0)THEN
Found Structure @ 17211
SUBROUTINE CALPUV2C
C
C ** PREVIOUS NAME WAS CALPUV2TC
C CHANGE RECORD
C MODIFIED DRYING AND WETTING SCHEME. THE OLD FORMULATION REMAINS
C SEE (ISDRY.GT.0.AND.ISDRY.LT.98). THE NEW FORMULATION IS ACTIVATED
C BY (ISDRY.EQ.99). ALSO ADDED OPTION TO WASTE WATER FROM ESSENTIALLY
C DRY CELLS HAVING WATER DEPTHS GREATER THAN HDRY. IE THE HIGH AND
C WET CELLS BLOCKED BY DRY CELLS. THIS IS ACTIVED BY A NEGATIVE VALUE
C OF NDRYSTP PARAMETER IS THE EFDC.INP FILE
Found Structure @ 18394
SUBROUTINE CALPUV2T
C
C CHANGE RECORD
C ADDED ALTERNATE SOR EQUATION SOLVER RELAX2T
C ** SUBROUTINE CALPUV2T CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
C ** SIGNIFICANTLY REWRITTEN SUBROUTINE BY PAUL M. CRAIG ON DEC-2004 TO
C ** ADDRESS INSTABIITIES. MODIFIED THE OPEN BOUNDARY CONDITION TREATMENT
Found Structure @ 19113
SUBROUTINE CALPUV9 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPUV9 CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP
Found Structure @ 19927
SUBROUTINE CALPUV9C (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPUV9 CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT
Found Structure @ 21059
SUBROUTINE CALQQ1 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
DELT=DT2
S3TL=1.0
Found Structure @ 21534
SUBROUTINE CALQQ1OLD (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
DELT=DT2
S3TL=1.0
Found Structure @ 21978
SUBROUTINE CALQQ2 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ2 CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED. THIS VERSION USES A SEPARATE ADVECTIVE
C ** TRANSPORT SUBROUTINE CALTRANQ
C
USE GLOBAL
DELT=DT2
Found Structure @ 22171
SUBROUTINE CALQQ2T (ISTL_)
C
C CHANGE RECORD
C FIXED DYNAMIC TIME STEPPING
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
IF(ISDYNSTP.EQ.0)THEN
Found Structure @ 22709
SUBROUTINE CALQQ2TOLD (ISTL_)
C
C CHANGE RECORD
C FIXED DYNAMIC TIME STEPPING
C 03/18/2004 PAUL CRAIG
C MADE CHANGES SO DML AND QQL ARE DIMENSIONALLY CORRECT
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
Found Structure @ 23227
SUBROUTINE CALQVS (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQVS UPDATES TIME VARIABLE VOLUME SOURCES
C
USE GLOBAL
REAL T1TMP,QWRABS
INTEGER*4 NS
REAL*8 :: DSTIME
Found Structure @ 23940
SUBROUTINE CALSED
C
C CHANGE RECORD
C ** SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
C
C**********************************************************************C
C
Found Structure @ 25037
SUBROUTINE CALSFT(ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALSFT CALCULATES THE TRANSPORT OF SHELL FISH LARVAE
C ** AT TIME LEVEL (N+1).
C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS (PMC - NO, CALLED IN BOTH HDMT & HDMT2T)
C
USE GLOBAL
! *** DSLLC BEGIN BLOCK
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKB
Found Structure @ 25366
SUBROUTINE CALSND
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
REAL::TIME,GRADSED,SIGP,CRNUM,DUM1,DUM3,DUM4,DIASED3
Found Structure @ 26733
SUBROUTINE CALSTEP
C
C CHANGE RECORD
C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE
C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL3
Found Structure @ 27027
SUBROUTINE CALSTEPD
C
C CHANGE RECORD
C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE
C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2
Found Structure @ 27345
SUBROUTINE CALTBXY(ISTL_,IS2TL_)
C
C ** SUBROUTINE CALTBXY CALCULATES BOTTOM FRICTION OR DRAG
C ** COEFFICIENTS IN QUADRATIC LAW FORM REFERENCED TO NEAR
C ** BOTTOM OR DEPTH AVERAGED HORIZONTAL VELOCITIES
C ** FOR VEGETATION RESISTANCE IN DEPTH INTEGRATED FLOW
C ** THE COEFFICIENT REPRESENTS BOTTOM AND WATER COLUMN VEGETATION
C ** RESISTANCE
C CHANGE RECORD
C REMOVED DRAG COEFFICIENT CONSTRAINT FOR MULIPLE LAYER ROUGHT
C BOUNDARIES WHEN DYNAMIC TIME STEPPING IS ACTIVE
Found Structure @ 28084
SUBROUTINE CALTOX
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TOXFPA
IF(.NOT.ALLOCATED(TOXFPA))THEN
Found Structure @ 29002
SUBROUTINE CALTOXB
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DIFTOXBW
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PARTDIF
Found Structure @ 29254
SUBROUTINE CALTRAN (ISTL_,IS2TL_,MVAR,MO,CON,CON1)
C
C CHANGE RECORD
C ADDED TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS
C ** SUBROUTINE CALTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
Found Structure @ 30612
SUBROUTINE CALTRANQ (ISTL_,M,QCON,QCON1)
C
C CHANGE RECORD
C ** SUBROUTINE CALTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
DIMENSION QCON(LCM,0:KCM),QCON1(LCM,0:KCM)
C
Found Structure @ 30816
SUBROUTINE CALTSXY
C
C CHANGE RECORD
C ** SUBROUTINE CALTSXY UPDATES TIME VARIABLE SURFACE WIND STRESS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT
Found Structure @ 31167
SUBROUTINE CALUVW (ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** CALCULATE THE INTERNAL SOLUTION AT TIME LEVEL (N+1)
C ** THE VALUE OF ISTL INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
C
IF(ISDYNSTP.EQ.0)THEN
DELT=DT2
Found Structure @ 31715
SUBROUTINE CALVEGSER (ISTL_)
C
C CHANGE RECORD
C NVEGSER = NUMBER OF VEGETATION TIME SERIES
C NVEGSERV(NVEGTPM) = TIME SERIES ID FOR SPECIFIC VEGETATION CLASS
C MVEGTLAST(NVEGSERM) = PLACE HOLDER IN INTERPOLATION TABLE
C TCVEGSER(NVEGSERM) = TIME CONVERSION FACTOR FOR TIME VARIABLE
C TVEGSER(NDVEGSER,NVEGSERM) = TIME OF DATA
C VEGSERRT(NVEGSERM) = CURRENT VALUE OF RDLPSQ
C VEGSERBT(NVEGSERM) = CURRENT VALUE OF BPVEG
Found Structure @ 31773
SUBROUTINE CALWQC(ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALWQC CALCULATES THE CONCENTRATION OF DISSOLVED AND
C ** SUSPENDED WATER QUALITY CONSTITUTENTS AT TIME LEVEL (N+1).
C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS
C
USE GLOBAL
REAL*8 :: DSTIME
Found Structure @ 32218
SUBROUTINE CBALEV1
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IF(NBALE.GT.1) RETURN
C
C ** INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
Found Structure @ 32275
SUBROUTINE CBALEV2
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** ACCUMULATE FLUXES ACROSS OPEN BOUNDARIES
C
Found Structure @ 32354
SUBROUTINE CBALEV3
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
REAL::QWRABS
C
C ** ACCUMULATE INTERNAL SOURCES AND SINKS
Found Structure @ 32518
SUBROUTINE CBALEV4
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
Found Structure @ 32552
SUBROUTINE CBALEV5
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CHECK FOR END OF BALANCE PERIOD
C
Found Structure @ 32753
SUBROUTINE CBALOD1
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IF(NBALO.GT.1) RETURN
C
C ** INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
Found Structure @ 32810
SUBROUTINE CBALOD2
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** ACCUMULATE FLUXES ACROSS OPEN BOUNDARIES
C
Found Structure @ 32889
SUBROUTINE CBALOD3
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
REAL::QWRABS
C
C ** ACCUMULATE INTERNAL SOURCES AND SINKS
Found Structure @ 33055
SUBROUTINE CBALOD4
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
Found Structure @ 33089
SUBROUTINE CBALOD5
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CHECK FOR END OF BALANCE PERIOD
C
Found Structure @ 33290
SUBROUTINE CELLMAP
C
C ** SUBROUTINE CELLMAP GENERATES CELL MAPPINGS
C CHANGE RECORD
C
USE GLOBAL
C
C ** SET 1D CELL INDEX SEQUENCE AND MAPPINGS
C
C OPEN(1,FILE='CELL9.OUT',STATUS='UNKNOWN')
Found Structure @ 33587
SUBROUTINE CELLMASK
C
C CHANGE RECORD
C ** SUBROUTINE CELLMASK CONVERTS LAND CELLS TO WATER CELLS BY
C ** MASKING VARIABLES. DEPTHS IN THE MASKED CELLS SHOULD BE INPUT AT
C ** THE END OF THE DXDY.INP FILE.
C
USE GLOBAL
OPEN(1,FILE='MASK.INP',STATUS='UNKNOWN')
DO NS=1,6
Found Structure @ 33742
SUBROUTINE CEQICM
C
C CHANGE RECORD
C ** SUBROUTINE FOR INTERFACING CE-QUAL-ICM MODEL
C
USE GLOBAL
! *** DSLLC
REAL,ALLOCATABLE,DIMENSION(:)::QINRCA
REAL,ALLOCATABLE,DIMENSION(:)::TMPICMF
Found Structure @ 34517
SUBROUTINE CONGRAD (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE
C ** GRADIENT SCHEME
C
USE GLOBAL
! *** DSLLC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH
Found Structure @ 34649
SUBROUTINE CONGRADC (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE
C ** GRADIENT SCHEME
C
USE GLOBAL
REAL*8 :: DSTIME
Found Structure @ 34832
SUBROUTINE COSTRAN (ISTL_,IS2TL_,MVAR,M,CON,CON1)
C
C CHANGE RECORD
C ADDED DYNAMIC TIME STEPPING
C ** SUBROUTINE COSTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
Found Structure @ 35791
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE COSTRANW (ISTL_,IS2TL_,MVAR,M,CON,CON1)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 36701
FUNCTION CSEDRESB(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES BULK EROSION RATE OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY AND OTHER VARIABLES
C ** CURRENT OPTIONS SHOULD NOT BE USED
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
Found Structure @ 36729
FUNCTION CSEDRESS(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES SURFACE EROSION RATE OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
Found Structure @ 36766
FUNCTION CSEDSET(LINDEX,SED,SHEAR,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES CONCENTRATION DEPENDENT SETTLING VELOCITY OF COHESIVE
C ** SEDIMENT
C *** DSLLC BEGIN BLOCK
C
IF(SED.LE.0.0001)THEN
Found Structure @ 36872
FUNCTION CSEDTAUB(DENBULK,TDUM,V1,V2,V3,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES CRITIAL STRESS FOR BULK OR MASS EROSION OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
Found Structure @ 36911
REAL FUNCTION CSEDTAUS(DENBULK,TAUCO,VDRO,VDR,VDRC,IOPT,L)
C
C CHANGE RECORD
C
C#######################################################################
C HQI ADDED, 11/18/2003, HAMRICK COMMENTED OUT SINCE NOT NEEDED FOR
C FOR 11/24 VERSION OF IOPT= 99 THAT IS ACTIVE AS OF 01/08/2004
C#######################################################################
C ** CALCULATES CRITIAL STRESS FOR SURFACE EROSION OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
Found Structure @ 36998
REAL FUNCTION CSEDVIS(SED)
C
C CHANGE RECORD
C
C
C ** CALCULATES KINEMATIC VISCOSITY OF HIGH CONCENTRATION COHESIVE
C ** SEDIMENT-WATER MIXTURE BASED ON
C **
C ** MEHTA, A. J., AND F.JIANG, 1990: SOME OBSERVATIONS ON BOTTOM
C ** MUD MOTION DUE TO WAVES. COASTAL AND OCEANOGRAPHIC ENGINEERING
Found Structure @ 37023
FUNCTION CSNDEQC(SNDDIA,SSG,WS,TAUR,TAUB,D50,SIGPHI,
& SNDDMX,IOPT,ISNDAL)
C
C CHANGE RECORD
C
C
C ** CALCULATES NEAR BED REFERENCE CONCENTRATION FOR NONCOHESIVE
C ** SEDIMENT
C ** IOPT=1 BASED ON
C **
Found Structure @ 37090
FUNCTION CSNDSET(SND,SDEN,IOPT)
C
C CHANGE RECORD
C ** CALCULATES HINDERED SETTLING CORRECTION FOR CLASS NS NONCOHESIVE
C ** SEDIMENT
C
ROPT=FLOAT(IOPT)
CSNDSET=(1.-SDEN*SND)**ROPT
RETURN
END
Found Structure @ 37101
FUNCTION CSNDZEQ(SNDDIA,GPDIASED,TAUR,TAUB,SNDDMX,DEP,
& IOPT,SSG,WS)
C
C CHANGE RECORD
C
C
C ** CALCULATES NEAR BED REFERENCE CONCENTRATION REFERENCE HEIGHT
C ** IOPT=1 BASED ON
C **
C ** GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT
Found Structure @ 37152
SUBROUTINE DEPPLT
C
C ** SUBROUTINE DEPPLT WRITES A FILE TO CONTOUR PLOT DEPTH
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*80 TITLE
OPEN(1,FILE='BELVCON.OUT',STATUS='UNKNOWN')
Found Structure @ 37185
MODULE DRIFTER
! *** DRIFTER.F90 IS A LAGRANGIAN PARTICLE TRACKING MODULE FOR THE DYNAMIC SOLUTIONS VERSION OF EFDC (I.E. EFDC_DS)
! *** THIS MODULE COMPLETELY REPLACES THE PREVIOUS VERSIONS OF PARTICLE TRACKING IN EFDC.
! *** THE CARDS C67 AND C68 IN THE EFDC.INP FILE WERE LEFT INTACT TO PROVIDE COMPATIBILITY WITH
! *** OTHER VERSIONS OF EFDC.
USE GLOBAL
IMPLICIT NONE
Found Structure @ 37358
SUBROUTINE DRIFTERINP
! ********************************************************************
!READING INPUT DATA OF INITIAL LOCATIONS OF DRIFTERS
!OUTPUT: NPD,XLA,YLA,ZLA,NP=1:NPD
! LA_BEGTI, LA_ENDTI, LA_FREQ,LANDT
INTEGER(4)::NP,I,J,K
REAL(RKD) ::XC(4),YC(4),AREA2,RANVAL
REAL(8),EXTERNAL::DRAND !IT NEEDS THIS STATEMENT IN CASE OF IMPLICIT NONE
OPEN(ULOC,FILE='DRIFTER.INP',ACTION='READ')
Found Structure @ 37399
SUBROUTINE READSTR(UINP) !******************************************************************
INTEGER(4),INTENT(IN)::UINP
CHARACTER(200)::STR
DO WHILE (1)
READ(UINP,'(A)') STR
STR=ADJUSTL(STR)
IF (STR(1:1).NE.'*') THEN
BACKSPACE(UINP)
RETURN
ENDIF
Found Structure @ 37412
SUBROUTINE CONTAINER(XLA,YLA,ZLA,LLA,KLA,NP) !**********************************************
!DETERMINING LLA,KLA,BELVLA,HPLA FOR THE FIRST CALL
!UPDATING XLA,YLA,LLA,KLA,BELVLA,HPLA FOR THE NEXT CALL
!FOR EACH DRIFTER (XLA,YLA,ZLA)
!BY FINDING THE NEAREST CELL CENTTROID
!THEN EXPANDING TO THE NEIGHBOUR CELLS
!HP(LIJ(I,J)) : WATER DEPTH = WATER SUR. - BELV
!BELV(LIJ(I,J)) : BOTTOM ELEVATION OF A CELL
!BELVLA : BED ELEVATION AT DRIFTER NI POSITION
!HPLA : WATER DEPTH AT DRIFTER NI POSITION
Found Structure @ 37660
SUBROUTINE SET_DRIFTER_OUT
XLA(NI)= XLA1
YLA(NI)= YLA1
ZLA(NI)= ZLA1
LLA(NI)= 1
END SUBROUTINE
END SUBROUTINE
Found Structure @ 37668
SUBROUTINE AREACAL(XC,YC,AREA) ! ***********************************************************
!AREA CALCULATION OF A POLYGON
!WITH GIVEN VEXTICES (XC,YC)
REAL(RKD),INTENT(IN) ::XC(:),YC(:)
REAL(RKD),INTENT(OUT)::AREA
REAL(RKD)::XVEC(2),YVEC(2)
INTEGER(4)::NPOL,K
NPOL = SIZE(XC)
AREA = 0
XVEC(1)=XC(2)-XC(1)
Found Structure @ 37688
SUBROUTINE DRIFVELCAL(LNI,KNI,NI,U1NI,V1NI,W1NI,U2NI,V2NI,W2NI) ! **************************
!CALCULATING VELOCITY COMPONENTS AT DRIFTER LOCATION
!BY USING INVERSE DISTANCE POWER 2 INTERPOLATION
!FOR VELOCITY COMPONENTS AT THE CENTROID OF POLYGON
INTEGER(4),INTENT(IN )::LNI,KNI,NI
REAL(RKD) ,INTENT(OUT)::U1NI,V1NI,W1NI,U2NI,V2NI,W2NI
INTEGER(4)::ICELL,JCELL,I,J,L,LN,K1,K2,KZ1,KZ2
REAL(RKD)::RAD2,SU1,SU2,SU3,SV1,SV2,SV3,SW1,SW2,SW3
REAL(RKD)::UTMPB,VTMPB,UTMPB1,VTMPB1,WTMPB,WTMPB1
REAL(RKD)::VELEK,VELNK,VELEK1,VELNK1,ZSIG
Found Structure @ 37785
SUBROUTINE RANDCAL(L,K,NP) ! ***************************************************************
INTEGER,INTENT(IN)::L,K,NP
REAL(8),EXTERNAL::DRAND
REAL(RKD)::COEF
IF (LA_PRAN==1.OR.LA_PRAN==3) THEN
IF (LA_DIFOP==0) THEN
COEF = SQRT(2*AH(L,K)*DT)
ELSE
COEF = SQRT(2*LA_HORDIF*DT)
ENDIF
Found Structure @ 37808
SUBROUTINE EDGEMOVE(LLA1,NI,ILN,JLN,NCASE,SCALE) ! ****************************************
!I,J,L:INDICES OF DRIFTER AT CURRENT POSITION
INTEGER(4),INTENT(IN)::LLA1,NI,ILN,JLN,NCASE
REAL(RKD), INTENT(IN)::SCALE
REAL(RKD)::UTMPB,VTMPB,VELM
INTEGER(4)::LN,KLA1
KLA1 = KLA(NI)
LN = LNC(LLA1) !
UTMPB = 0.5*STCUV(LLA1)*(RSSBCE(LLA1)*U1(LLA1+1,KLA(NI))+RSSBCW(LLA1)*U1(LLA1,KLA(NI)))
Found Structure @ 37880
SUBROUTINE RESET_LLA(I1,I2,J1,J2)
INTEGER(4),INTENT(IN)::I1,I2,J1,J2
INTEGER(4)::I,J,L
REAL(RKD)::VELEK,VELNK
VELEK =CUE(LLA1)*UTMPB+CVE(LLA1)*VTMPB
VELNK =CUN(LLA1)*UTMPB+CVN(LLA1)*VTMPB
XLA(NI)=XLA1+ DT*VELEK
YLA(NI)=YLA1+ DT*VELNK
DO J=J1,J2
Found Structure @ 37907
FUNCTION INSIDECELL(L,XM,YM) RESULT(INSIDE) ! **********************************************
LOGICAL(4)::INSIDE
INTEGER(4),INTENT(IN)::L
REAL(RKD) ,INTENT(IN)::XM,YM
REAL(RKD) ::XC(6),YC(6),AREA2
XC(1) = XM
YC(1) = YM
XC(2:5)=XCOR(L,1:4)
YC(2:5)=YCOR(L,1:4)
Found Structure @ 37927
SUBROUTINE DRIFTERWDEP(LNI,NI,BELVNI,HPNI) !************************************************
!INTERPOLATION OF THE TOTAL WATER DEPTH AND BOTTOM ELEVATION
!FOR THE DRIFTER NI AT EACH TIME INSTANT AND EACH LOCATION
INTEGER(4),INTENT(IN)::LNI,NI
REAL(RKD),INTENT(OUT)::BELVNI,HPNI
INTEGER(4)::ICELL,JCELL,L,I,J
REAL(RKD) ::BELVNI1,BELVNI2,RAD2,ZETA
ICELL = IL(LNI)
JCELL = JL(LNI)
Found Structure @ 37955
SUBROUTINE DRIFTERLAYER(LNI,NI,BELVNI,HPNI,KLN,ZLN)
!RECALCULATE ZLA(NI)
!DETERMINE KLA(NI)
INTEGER(4),INTENT(IN)::LNI,NI
REAL(RKD), INTENT(IN)::BELVNI,HPNI
INTEGER(4),INTENT(OUT)::KLN
REAL(RKD), INTENT(INOUT)::ZLN
INTEGER(4)::K
REAL(RKD) ::ZSIG
IF (LNI.GE.2) THEN
Found Structure @ 37977
FUNCTION SIGNV(V)
REAL(RKD),INTENT(IN)::V
INTEGER(4)::SIGNV
IF (V>=0) THEN
SIGNV= 1
ELSE
SIGNV=-1
ENDIF
END FUNCTION
Found Structure @ 37987
SUBROUTINE AREA_CENTRD
!DETERMINING CELLCENTROID OF ALL CELLS
!AND CALCULATING THE AREA OF EACH CELL
INTEGER(4)::I,J,K
REAL(RKD)::XC(4),YC(4),AREA2
OPEN(UCOR,FILE='CORNERS.INP',ACTION='READ')
CALL READSTR(UCOR)
ALLOCATE(XCOR(LA,5),YCOR(LA,5),AREA(LA))
XCOR = 0
YCOR = 0
Found Structure @ 38014
END MODULE
REAL*8 FUNCTION DSTIME()
! *** Generic Function to Provide Model Timing
! *** DSTIME returns back the number of seconds since some event
!USE IFPORT
USE IFLPORT
REAL*4::TARR(2), TPMC
REAL*4,STATIC::LASTTIME
! *** CHANGE THE FOLLOWING LINES TO CORRESPOND TO THE PLATORM AND COMPILER
Found Structure @ 38043
SUBROUTINE DUMP
C
C CHANGE RECORD
C ** SUBROUTINE DUMP WRITES FULL FIELD DUMPS OF MODEL VARIABLES
C ** AT SPECIFIED TIME INTERVALS
C
USE GLOBAL
CHARACTER*1 CZTT(0:9)
CHARACTER*1 CCHTMF,CCHTMS
C
CHARACTER*2,ALLOCATABLE,DIMENSION(:)::CNTTOX
Found Structure @ 39548
SUBROUTINE EEXPOUT(JSEXPLORER)
!----------------------------------------------------------------
! ** SUBROUTINE EEXPOUT WRITES BINARY OUTPUT FILES:
! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS
! ** EE_BED - SEDIMENT BED LAYER INFORMATION
! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN
! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION
! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO
Found Structure @ 40156
C
C **********************************************************************
C
PROGRAM EFDC
C
C ** WELCOME TO THE ENVIRONMENTAL FLUID DYNAMICS COMPUTER CODE SERIES
C ** DEVELOPED BY JOHN M. HAMRICK. THE EFDC CODE WAS ORGINALLY
C ** DEVELOPED AT VIRGINIA INSTITUTE OF MARINE SCIENCE
C ** /SCHOOL OF MARINE SCIENCE, THE COLLEGE OF
C ** WILLIAM AND MARY, GLOUCESTER POINT, VA 23062
C ** THIS SOURCE FILE IS A DIRECT RELEASE BY THE DEVELOPER
Found Structure @ 42277
FUNCTION FDSTRSE(VOID,BMECH1,BMECH2,BMECH3)
C
C CHANGE RECORD
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C
C
C ** FDSTRSE IS COMPRESSION LENGTH SCALE
C STRESS WITH RESPECT TO VOID RATIO
C
IF(BMECH1.GT.0.0)THEN
Found Structure @ 42303
FUNCTION FHYDCN(VOID,BMECH4,BMECH5,BMECH6,IBMECHK)
C
C CHANGE RECORD
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C
C
C ** FHYDCN IS HYDRAULIC CONDUCTIVITY DIVIDED BY 1+VOID RATIO
C
IF(BMECH4.GT.0.0)THEN
TMP=(VOID-BMECH5)/BMECH6
Found Structure @ 42326
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE FOODCHAIN(IFINISH)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 43060
FUNCTION FSBDLD(DIASED,GPDIASED,D50,DEP,PEXP,PHID,CSHIELDS,
& SBDLDP,ISOPT)
C
C CHANGE RECORD
C MODIFED TO INCLUDE ALTERNATE FORMULAS FOR BED LOAD PHI
C
C
C ** CALCULATES DIMNSIONLESS BED LOAD TRANSPORT COEFFICIENT
C ** ISOPT=0 USE CONSTANT VALUE
C
IF(ISOPT.EQ.0) FSBDLD=SBDLDP
Found Structure @ 43102
FUNCTION FSEDMODE(WS,USTOT,USGRN,RSNDM,ISNDM1,ISNDM2,IMODE)
C
C ** FSEDMODE SETS BEDLOAD (IMODE=1) AND SUSPENDED LOAD (IMODE=2)
C ** TRANSPORT FRACTIONS
C
C
C CHOOSE BETWEEEN TOTAL STRESS SHEAR VELOCITY AND GRAIN STRESS
C SHEAR VELOCITY
C
Found Structure @ 43177
FUNCTION FSTRSE(VOID,BMECH1,BMECH2,BMECH3)
C
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C CHANGE RECORD
C
C
C ** FSTRSE IS WATER SPECIFIC WEIGHT NORMALIZED EFFECTIVE STRESS
C
IF(BMECH1.GT.0.0)THEN
TMP=-(VOID-BMECH2)/BMECH3
FSTRSE=BMECH1*EXP(TMP)
Found Structure @ 43198
FUNCTION FUNDEN(SAL,SED,TEM)
C
C ** FUNDEN CALCULATED DENSITY AS A FUNTION OF SAL,TEM,AND SED
C CHANGE RECORD
C IMPLICIT REAL*8 (A-H,O-Z)
C
REAL TTMP,SSG,SDEN,SSTMP,RHTMP,RHO
SSG=2.5
SDEN=1./2500000.
Found Structure @ 43231
SUBROUTINE HDMT
C
C ** SUBROUTINE HDMT EXECUTES THE FULL HYDRODYNAMIC AND MASS TRANSPORT
C ** TIME INTERGATION
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C----------------------------------------------------------------------C
C
C CHANGE RECORD
Found Structure @ 44872
SUBROUTINE HDMT2T
C
C ** SUBROUTINE HDMT2T EXECUTES THE FULL HYDRODYNAMIC AND MASS
C ** TRANSPORT TIME INTERGATION USING A TWO TIME LEVEL SCHEME
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION
C
C----------------------------------------------------------------------C
C
C CHANGE RECORD
C DATE MODIFIED BY DATE APPROVED BY
Found Structure @ 46801
SUBROUTINE INITBIN
C
C**********************************************************************C
C
C M.R. MORTON 23 JUL 1998
C
C ** LAST MODIFIED BY JOHN HAMRICK AND MIKE MORTON ON 8 AUGUST 2001
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 47237
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE INITBIN2
C
C**********************************************************************C
C
C M.R. MORTON 01 APR 1999
C
Found Structure @ 47485
SUBROUTINE INITBIN3
C
C M.R. MORTON 29 APR 1999
C CHANGE RECORD
C INITIALIZES BINARY FILE FOR EFDC OUTPUT. PLACES CONTROL
C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY
C FILE WQDOCOMP.BIN FOR D.O. COMPONENT ANALYSIS.
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT
Found Structure @ 47754
SUBROUTINE INITBIN4
C
C M.R. MORTON 02 JUN 1999
C CHANGE RECORD
C INITIALIZES BINARY FILE FOR EFDC OUTPUT. PLACES CONTROL
C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY
C FILE WQSDTS.BIN FOR BENTHIC FLUX RATES.
C
USE GLOBAL
Found Structure @ 47951
SUBROUTINE INPUT(TITLE)
C
C ** SUBROUTINE INPUT READS ALL INPUT DATA EXCEPT DATA IN LXLY.INP,
C ** MASK.INP AND RESTART.INP
C CHANGE RECORD
C ADDED BODY FORCE SWITCH ISBODYF (C14) AND READ OF INPUT FILE
C FBODY.INP CONTAINING THE BODY FORCE FBODYFX AND FBODYFY
C MODIFIED BED MECHANICS COEFFICIENT SET ON (C38)
C MODIFIED BEDLOAD FUNCTIONAL RELATIONSHIP TO MORE GENERAL FORM (C42A)
C ADDED BEDLOAD OUTFLOW/RECIRCULATION BOUNDARY CONDTION SWITCH (C42A)
Found Structure @ 52537
! *** DSLLC UTIL
FUNCTION PARSE_REAL(INLINE)
CHARACTER*(*) INLINE
CHARACTER*15 CVAL,TMPVAL
ILEN=LEN_TRIM(INLINE)
PARSE_REAL=0.
DO IC=1,ILEN
IF(INLINE(IC:IC).EQ.':')THEN
Found Structure @ 52567
FUNCTION PARSE_LOGICAL(INLINE)
CHARACTER*(*) INLINE
CHARACTER*12 CVAL
LOGICAL PARSE_LOGICAL
ILEN=LEN_TRIM(INLINE)
DO IC=1,ILEN
IF(INLINE(IC:IC).EQ.':')THEN
DO IPOS=IC+1,ILEN
Found Structure @ 52598
SUBROUTINE JPEFDC
C
C ** PROGRAM JPEFDC IS STAND ALONE VERSION OF EFDC JET-PLUME MODEL
C ** BASED ON LEE AND CHEUNG'S LAGRANGIAN BUOYANT JET MODEL
C ** AND EXTENDED FOR THREE-DIMENSIONAL AMBIENT CURRENTS
C ** REF: LEE, J.H.W., AND V. CHEUNG, J. ENVIRON. ENGR., 116, 1085-
C ** 1106, 1990.
C ** FOR MORE INFO EMAIL [email protected]
C CHANGE RECORD
C
USE GLOBAL
Found Structure @ 54348
SUBROUTINE LSQHARM
C
C CHANGE RECORD
C ** SUBROUTINE LSQHARM PERFORMS A LEAST SQUARES HARMONIC ANALYSIS
C
USE GLOBAL
CHARACTER*80 TITLE,TITNT,TITRT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::AMATMP
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PPPTMP
Found Structure @ 55236
SUBROUTINE LUBKSB(A,N,NP,INDX,B)
C
C CHANGE RECORD
C
DIMENSION A(NP,NP),B(N),INDX(N)
C
II=0
DO 12 I=1,N
LL=INDX(I)
SUM=B(LL)
Found Structure @ 55268
SUBROUTINE LUDCMP(A,N,NP,INDX,D)
C
C CHANGE RECORD
C
PARAMETER (TINY=1.0E-20)
DIMENSION A(NP,NP),INDX(N)
REAL,ALLOCATABLE,DIMENSION(:)::VV
ALLOCATE(VV(N))
C
D=1.
SUBROUTINE ACON(ITVAL)
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NJELM,NATDM,ITVAL,NT,NS,NX,NZ,NZP
REAL::WTNZP,WTNZ
PARAMETER (NJELM=2,NATDM=1)
Found Structure @ 79
SUBROUTINE AINIT
C
C CHANGE RECORD
C ADDED TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS
C ADDED TRANSPORT BYPASS MASK, LMASKDRY FOR DRY CELLS
C MODIFIED DEFINITION OF CHANLEN IN INITIALIZATION RATHER THAN
C IN SUBS CALTBXY AND CALPUV2C AND CALPUV9C
C
C ALL ZEROING OF ARRAYS MOVED TO ZERO
C
Found Structure @ 441
SUBROUTINE BAL2T1
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 619
SUBROUTINE BAL2T2
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 772
SUBROUTINE BAL2T3A
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C MODIFIED SND MASS BALANCE WITH RESPECT TO BED LOAD OUTFLOW
C ADDED QDWASTE TO WATER MASS BALANCE
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
Found Structure @ 1170
SUBROUTINE BAL2T3B(IBALSTDT)
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C MODIFIED SND MASS BALANCE WITH RESPECT TO BED LOAD OUTFLOW
C ADDED QDWASTE TO WATER MASS BALANCE
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
Found Structure @ 1294
SUBROUTINE BAL2T4
C
C CHANGE RECORD
C SUBROUTINE ADDED FOR 2 TIME-LEVEL BALANCES INCLUDING SED,SND,TOX
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
Found Structure @ 1336
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE BAL2T5
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 2148
SUBROUTINE BEDINIT
C
C ** SUBROUTINE BEDINIT INITIALIZES SEDIMENT AND TOXIC VARIABLES
C ** IT SEDIMENT BED FOR HOT AND COLD START CONDITIONS
C CHANGE RECORD
C ADDED ADDITIONAL DIAGNOSTIC OUTPUT
C MOVED TOXIC INITIALIZATIONS FROM SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 3620
SUBROUTINE BEDLOAD(NX,NS)
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,NSB,LUTMP,LDTMP,LS,LN,NX,NS
Found Structure @ 4135
SUBROUTINE BEDPLTH
C
C CHANGE RECORD
C 11/14/2001 JOHN HAMRIC 11/14/2001 JOHN HAMRIC
C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY
C ** SUBROUTINE WRITES SEDIMENT BED PROPERTIES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,K,NX,NS,NSXD,KTMP
Found Structure @ 4352
SUBROUTINE BUDGET1
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,NS
IF(NBUD.GT.1) RETURN
Found Structure @ 4478
SUBROUTINE BUDGET2
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::LS,NT,LL,K,L,LN
C
Found Structure @ 4574
SUBROUTINE BUDGET3
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,NS,NWR,NCTL,ID,JD,LD,KU,KD,M,IU,JU,LU
Found Structure @ 4822
SUBROUTINE BUDGET5
C
C ** ADDED BY DON KINGERY, CH2M-HILL ON 15 OCTOBER 1996
C CHANGE RECORD
C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NS,L,K
REAL::SEDBTMP1,SEDBTMP,SFLXTMP,BSEDERR,SSEDOUT,BSEDOUT,SSEDERE
Found Structure @ 5077
SUBROUTINE CALAVB (ISTL_)
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
C
USE GLOBAL
Found Structure @ 5254
SUBROUTINE CALAVB2 (ISTL_)
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C
USE GLOBAL
Found Structure @ 5420
SUBROUTINE CALAVBOLD (ISTL_)
C
C *** OLD STANDARD
C
C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
Found Structure @ 5589
SUBROUTINE CALBAL1
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
IF(NBAL.GT.1) RETURN
Found Structure @ 5648
SUBROUTINE CALBAL2
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::LL,K,LS,L,LN
C
Found Structure @ 5729
SUBROUTINE CALBAL3
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,K,LL,NS,NQSTMP,NCSTMP,NCTL,IU,JU,LU
Found Structure @ 5897
SUBROUTINE CALBAL4
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
INTEGER::L,LN,K
REAL::DUTMP,DVTMP
Found Structure @ 5933
SUBROUTINE CALBAL5
C
C CHANGE RECORD
C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IMPLICIT NONE
REAL::ENEEND,ENEOUT,VOLBMO,SALBMO,DYEBMO,UMOBMO,VMOBMO,ENEBMO
REAL::VOLERR,SALERR,DYEERR,UMOERR,VMOERR,ENEERR,RVERDE,RSERDE
Found Structure @ 6139
SUBROUTINE CALBED
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVE SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IFLAG,LUTMP,NS,NSB,KK,NX,KBTM1
Found Structure @ 6967
SUBROUTINE CALBED9
C
C CHANGE RECORD
C ** SUBROUTINE CALBED9 CALCULATES CALCULATES BED CONSOLIDATION
C WHERE A DIFFERENT TYPE OF CONSOLIDATION CAN BE USED FOR EACH
C CELL
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IFLAG,KK,NSB,LUTMP,NS,NX,KBTM1
Found Structure @ 7920
SUBROUTINE CALBLAY
C
C CHANGE RECORD
C ** SUBROUTINE CALBLAY REMOVES OR ADDS LAYERS TO THE SEDIMENT BED
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,NS,L,NT,NX
REAL::TMPBOT2,TMPTOP1,TMPTOP2,TMPVAL,HBEDMXT,HOLDTOP,FKBTP
Found Structure @ 8550
SUBROUTINE CALBUOY
C
C CHANGE RECORD
C ** CALBUOY CALCULATES THE BUOYANCY USING MELLOR'S APPROXIMATION
C ** TO THE UNESCO EQUATION OF STATE (MELLOR, G.L., J. ATM AND OCEAN
C ** TECH, VOL 8, P 609)
C
USE GLOBAL
IMPLICIT NONE
INTEGER::NS,K,L
Found Structure @ 8693
SUBROUTINE CALCONC (ISTL_,IS2TL_)
C
C CHANGE RECORD
C MODIFIED CALLS TO CALBAL AND BUDGET SUBROUTINES
C ADDED CALLS TO BAL2T2, BAL2T3
C ** SUBROUTINE CALCULATES THE CONCENTRATION OF DISSOLVED AND
C ** SUSPENDED CONSTITUTENTS, INCLUDING SALINITY, TEMPERATURE, DYE AND
C ** AND SUSPENDED SEDIMENT AT TIME LEVEL (N+1). THE VALUE OF ISTL
C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
Found Structure @ 9692
C
SUBROUTINE CALCSER (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SALINITY, TEMPERATURE
C ** DYE, SEDIMENT, AND SHELL FISH LARVAE
C ** BOUNDARY CONDITIONS AND INFLOW CONCENTRATIONS
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 9975
SUBROUTINE CALDIFF (ISTL_,M,CON1)
C
C CHANGE RECORD
C ** SUBROUTINE CALDIFF CALCULATES THE HORIZONTAL DIFFUSIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A REVISEDED VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL
C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
IMPLICIT NONE
Found Structure @ 10003
SUBROUTINE CALDISP2
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,KK,KT,L,LN
REAL::CLTMP,CTMP,AMCPT,AMSPT,UAVG,VAVG,CUTMP,CMTMP
REAL::CCUU,CCVV,CCUV,CCVU
Found Structure @ 10308
SUBROUTINE CALDISP3
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,KK,L,LS,KT,LN
REAL::CLTMP,DDD,CMTMP,DXXTMP,WTX,DXXWEST,DXXEAST
REAL::DXXSOUT,DXXNORT,WTY,DYXWEST,DYXEAST,DYXSOUT,DYXNORT
Found Structure @ 10786
SUBROUTINE CALEBI
C
C CHANGE RECORD
C ** CALEBI CALCULATES THE EXTERNAL BUOYANCY INTEGRALS
C
USE GLOBAL
IMPLICIT NONE
INTEGER::K,L,IPMC,LLCM
REAL::EPSILON,DBK,DZCBK
Found Structure @ 10834
SUBROUTINE CALEXP (ISTL_)
C
C ** SUBROUTINE CALEXP CALCULATES EXPLICIT MOMENTUM EQUATION TERMS
C ** THIS SUBROUTINE IS CURRENT PRODUCTION VERSION
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
C
C----------------------------------------------------------------------C
Found Structure @ 11825
SUBROUTINE CALEXP2T
C
C ** SUBROUTINE CALEXP2T CALCULATES EXPLICIT MOMENTUM EQUATION TERMS
C ** USING A TWO TIME LEVEL SCHEME
C CHANGE RECORD
C ADDED BODY FORCES FBODYFX AND FBODYFY TO EXTERNAL MOMENTUM EQUATIONS
C CORRECTED ORIENTATION OF MOMENTUM FLUXES FROM SINKS AND SOURCE
C CORRECTED 2 LAYER (KC=-2) CURVATURE ACCELERATION CORRECTION
C ADDED ICK2COR,CK2UUM,CK2VVM,CK2UVM,CK2UUC,CK2VVC,CK2UVC,CK2FCX,
C CK2FCY TO GENERALIZE TWO LAYER MOMENTUM FLUX AND CURVATURE
C ACCELERATION CORRECTION
Found Structure @ 13057
SUBROUTINE CALFQC(ISTL_,IS2TL_,MVAR,MO,CON,CON1,FQCPAD,QSUMPAD,
& QSUMNAD)
C
C CHANGE RECORD
C ** SUBROUTINE CALFQC CALCULATES MASS SOURCES AND SINKS ASSOCIATED
C ** WITH CONSTANT AND TIME SERIES INFLOWS AND OUTFLOWS; CONTROL
C ** STRUCTURE INFLOWS AND OUTLOWS; WITHDRAWAL AND RETURN STRUCTURE
C ** OUTFLOWS; AND EMBEDED CHANNEL INFLOWS AND OUTFLOWS
C
USE GLOBAL
Found Structure @ 14189
SUBROUTINE CALHDMF
C
C *** CALDMF CALCULATES THE HORIZONTAL VISCOSITY AND
C *** DIFFUSIVE MOMENTUM FLUXES. THE VISCOSITY, AH IS CALCULATED USING
C *** SMAGORINSKY'S SUBGRID SCALE FORMULATION PLUS A CONSTANT AHO
C
C *** ONLY VALID FOR ISHDMF.GE.1
C
C CHANGE RECORD
C REWRITTEN BY PAUL M. CRAIG NOV/DEC 2004
Found Structure @ 14495
SUBROUTINE CALHEAT(ISTL_)
C
C Subroutine CALHEAT takes the information from the atmospheric boundary
C file and the wind forcing file and calculates the net heat flux across
C the water surface boundary. The heat flux is then used to update the
C water temperature either in the surface cells, or distributed across
C the cells in the vertical and into the bottom. The subroutine has
C three options these are:
C
C ISOPT(2)=1: Full surface and internal heat transfer calculation
C using meteorologic data from input stream.
Found Structure @ 15052
************************************************************************
** S U B R O U T I N E H E A T E X C H A N G E **
** **
** FROM CE-QUAL-W2 (VER 3.1) **
** **
************************************************************************
SUBROUTINE HEAT_EXCHANGE
USE GLOBAL
Found Structure @ 15215
SUBROUTINE CALHTA
C
C CHANGE RECORD
C ** SUBROUTINE CALHTA PERFORMS A HARMONIC ANALYSIS FOR THE M2 TIDE
C ** OVER TWO TIDAL CYCLES
C
USE GLOBAL
CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE11,TITLE12
C
C ** INITIALIZE ON FIRST ENTRY FOR CURRENT ANALYSIS INTERVAL
Found Structure @ 15462
SUBROUTINE CALIMP2T
C
C ** SUBROUTINE CALEXP CALCULATES IMPLICIT MOMENTUM EQUATION
C ** CORIOLIS AND CURVATURE TERMS FOR 1/2 STEP PREDICTOR
C CHANGE RECORD
C
USE GLOBAL
IF(ISDYNSTP.EQ.0)THEN
DELT=DT
DELTD2=0.5*DT
Found Structure @ 15993
SUBROUTINE CALMMT
C
C CHANGE RECORD
C ** SUBROUTINE CALMMTF CALCULATES THE MEAN MASS TRANSPORT FIELD
C
USE GLOBAL
C
LOGICAL INITIALIZE
DATA INITIALIZE/.TRUE./
C
Found Structure @ 16982
SUBROUTINE CALPNHS
C
C CHANGE RECORD
C ** SUBROUTINE CALPNHS CALCULATES QUASI-NONHYDROSTATIC PRESSURE
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PNHYDSS
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FWJET
REAL::QWRABS
Found Structure @ 17179
SUBROUTINE CALPSER (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SURFACE ELEVATION
C ** BOUNDARY CONDITIONS
C
USE GLOBAL
PSERT(0)=0.
DO NS=1,NPSER
IF(ISDYNSTP.EQ.0)THEN
Found Structure @ 17211
SUBROUTINE CALPUV2C
C
C ** PREVIOUS NAME WAS CALPUV2TC
C CHANGE RECORD
C MODIFIED DRYING AND WETTING SCHEME. THE OLD FORMULATION REMAINS
C SEE (ISDRY.GT.0.AND.ISDRY.LT.98). THE NEW FORMULATION IS ACTIVATED
C BY (ISDRY.EQ.99). ALSO ADDED OPTION TO WASTE WATER FROM ESSENTIALLY
C DRY CELLS HAVING WATER DEPTHS GREATER THAN HDRY. IE THE HIGH AND
C WET CELLS BLOCKED BY DRY CELLS. THIS IS ACTIVED BY A NEGATIVE VALUE
C OF NDRYSTP PARAMETER IS THE EFDC.INP FILE
Found Structure @ 18394
SUBROUTINE CALPUV2T
C
C CHANGE RECORD
C ADDED ALTERNATE SOR EQUATION SOLVER RELAX2T
C ** SUBROUTINE CALPUV2T CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
C ** SIGNIFICANTLY REWRITTEN SUBROUTINE BY PAUL M. CRAIG ON DEC-2004 TO
C ** ADDRESS INSTABIITIES. MODIFIED THE OPEN BOUNDARY CONDITION TREATMENT
Found Structure @ 19113
SUBROUTINE CALPUV9 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPUV9 CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP
Found Structure @ 19927
SUBROUTINE CALPUV9C (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALPUV9 CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE,
C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING
C ** AND DRYING OF CELLS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT
Found Structure @ 21059
SUBROUTINE CALQQ1 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
DELT=DT2
S3TL=1.0
Found Structure @ 21534
SUBROUTINE CALQQ1OLD (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
DELT=DT2
S3TL=1.0
Found Structure @ 21978
SUBROUTINE CALQQ2 (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQQ2 CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED. THIS VERSION USES A SEPARATE ADVECTIVE
C ** TRANSPORT SUBROUTINE CALTRANQ
C
USE GLOBAL
DELT=DT2
Found Structure @ 22171
SUBROUTINE CALQQ2T (ISTL_)
C
C CHANGE RECORD
C FIXED DYNAMIC TIME STEPPING
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
USE GLOBAL
IF(ISDYNSTP.EQ.0)THEN
Found Structure @ 22709
SUBROUTINE CALQQ2TOLD (ISTL_)
C
C CHANGE RECORD
C FIXED DYNAMIC TIME STEPPING
C 03/18/2004 PAUL CRAIG
C MADE CHANGES SO DML AND QQL ARE DIMENSIONALLY CORRECT
C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT
C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF
C ** TIME LEVELS INVOLVED
C
Found Structure @ 23227
SUBROUTINE CALQVS (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALQVS UPDATES TIME VARIABLE VOLUME SOURCES
C
USE GLOBAL
REAL T1TMP,QWRABS
INTEGER*4 NS
REAL*8 :: DSTIME
Found Structure @ 23940
SUBROUTINE CALSED
C
C CHANGE RECORD
C ** SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
C
C**********************************************************************C
C
Found Structure @ 25037
SUBROUTINE CALSFT(ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALSFT CALCULATES THE TRANSPORT OF SHELL FISH LARVAE
C ** AT TIME LEVEL (N+1).
C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS (PMC - NO, CALLED IN BOTH HDMT & HDMT2T)
C
USE GLOBAL
! *** DSLLC BEGIN BLOCK
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKB
Found Structure @ 25366
SUBROUTINE CALSND
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IMPLICIT NONE
REAL::TIME,GRADSED,SIGP,CRNUM,DUM1,DUM3,DUM4,DIASED3
Found Structure @ 26733
SUBROUTINE CALSTEP
C
C CHANGE RECORD
C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE
C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL3
Found Structure @ 27027
SUBROUTINE CALSTEPD
C
C CHANGE RECORD
C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE
C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2
Found Structure @ 27345
SUBROUTINE CALTBXY(ISTL_,IS2TL_)
C
C ** SUBROUTINE CALTBXY CALCULATES BOTTOM FRICTION OR DRAG
C ** COEFFICIENTS IN QUADRATIC LAW FORM REFERENCED TO NEAR
C ** BOTTOM OR DEPTH AVERAGED HORIZONTAL VELOCITIES
C ** FOR VEGETATION RESISTANCE IN DEPTH INTEGRATED FLOW
C ** THE COEFFICIENT REPRESENTS BOTTOM AND WATER COLUMN VEGETATION
C ** RESISTANCE
C CHANGE RECORD
C REMOVED DRAG COEFFICIENT CONSTRAINT FOR MULIPLE LAYER ROUGHT
C BOUNDARIES WHEN DYNAMIC TIME STEPPING IS ACTIVE
Found Structure @ 28084
SUBROUTINE CALTOX
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TOXFPA
IF(.NOT.ALLOCATED(TOXFPA))THEN
Found Structure @ 29002
SUBROUTINE CALTOXB
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DIFTOXBW
REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PARTDIF
Found Structure @ 29254
SUBROUTINE CALTRAN (ISTL_,IS2TL_,MVAR,MO,CON,CON1)
C
C CHANGE RECORD
C ADDED TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS
C ** SUBROUTINE CALTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
Found Structure @ 30612
SUBROUTINE CALTRANQ (ISTL_,M,QCON,QCON1)
C
C CHANGE RECORD
C ** SUBROUTINE CALTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
DIMENSION QCON(LCM,0:KCM),QCON1(LCM,0:KCM)
C
Found Structure @ 30816
SUBROUTINE CALTSXY
C
C CHANGE RECORD
C ** SUBROUTINE CALTSXY UPDATES TIME VARIABLE SURFACE WIND STRESS
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT
Found Structure @ 31167
SUBROUTINE CALUVW (ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** CALCULATE THE INTERNAL SOLUTION AT TIME LEVEL (N+1)
C ** THE VALUE OF ISTL INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
C
IF(ISDYNSTP.EQ.0)THEN
DELT=DT2
Found Structure @ 31715
SUBROUTINE CALVEGSER (ISTL_)
C
C CHANGE RECORD
C NVEGSER = NUMBER OF VEGETATION TIME SERIES
C NVEGSERV(NVEGTPM) = TIME SERIES ID FOR SPECIFIC VEGETATION CLASS
C MVEGTLAST(NVEGSERM) = PLACE HOLDER IN INTERPOLATION TABLE
C TCVEGSER(NVEGSERM) = TIME CONVERSION FACTOR FOR TIME VARIABLE
C TVEGSER(NDVEGSER,NVEGSERM) = TIME OF DATA
C VEGSERRT(NVEGSERM) = CURRENT VALUE OF RDLPSQ
C VEGSERBT(NVEGSERM) = CURRENT VALUE OF BPVEG
Found Structure @ 31773
SUBROUTINE CALWQC(ISTL_,IS2TL_)
C
C CHANGE RECORD
C ** SUBROUTINE CALWQC CALCULATES THE CONCENTRATION OF DISSOLVED AND
C ** SUSPENDED WATER QUALITY CONSTITUTENTS AT TIME LEVEL (N+1).
C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS
C
USE GLOBAL
REAL*8 :: DSTIME
Found Structure @ 32218
SUBROUTINE CBALEV1
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IF(NBALE.GT.1) RETURN
C
C ** INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
Found Structure @ 32275
SUBROUTINE CBALEV2
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** ACCUMULATE FLUXES ACROSS OPEN BOUNDARIES
C
Found Structure @ 32354
SUBROUTINE CBALEV3
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
REAL::QWRABS
C
C ** ACCUMULATE INTERNAL SOURCES AND SINKS
Found Structure @ 32518
SUBROUTINE CBALEV4
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
Found Structure @ 32552
SUBROUTINE CBALEV5
C
C CHANGE RECORD
C ** SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CHECK FOR END OF BALANCE PERIOD
C
Found Structure @ 32753
SUBROUTINE CBALOD1
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
IF(NBALO.GT.1) RETURN
C
C ** INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
Found Structure @ 32810
SUBROUTINE CBALOD2
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** ACCUMULATE FLUXES ACROSS OPEN BOUNDARIES
C
Found Structure @ 32889
SUBROUTINE CBALOD3
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
REAL::QWRABS
C
C ** ACCUMULATE INTERNAL SOURCES AND SINKS
Found Structure @ 33055
SUBROUTINE CBALOD4
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
Found Structure @ 33089
SUBROUTINE CBALOD5
C
C CHANGE RECORD
C ** SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C ** AND ENERGY BALANCES
C
USE GLOBAL
C
C ** CHECK FOR END OF BALANCE PERIOD
C
Found Structure @ 33290
SUBROUTINE CELLMAP
C
C ** SUBROUTINE CELLMAP GENERATES CELL MAPPINGS
C CHANGE RECORD
C
USE GLOBAL
C
C ** SET 1D CELL INDEX SEQUENCE AND MAPPINGS
C
C OPEN(1,FILE='CELL9.OUT',STATUS='UNKNOWN')
Found Structure @ 33587
SUBROUTINE CELLMASK
C
C CHANGE RECORD
C ** SUBROUTINE CELLMASK CONVERTS LAND CELLS TO WATER CELLS BY
C ** MASKING VARIABLES. DEPTHS IN THE MASKED CELLS SHOULD BE INPUT AT
C ** THE END OF THE DXDY.INP FILE.
C
USE GLOBAL
OPEN(1,FILE='MASK.INP',STATUS='UNKNOWN')
DO NS=1,6
Found Structure @ 33742
SUBROUTINE CEQICM
C
C CHANGE RECORD
C ** SUBROUTINE FOR INTERFACING CE-QUAL-ICM MODEL
C
USE GLOBAL
! *** DSLLC
REAL,ALLOCATABLE,DIMENSION(:)::QINRCA
REAL,ALLOCATABLE,DIMENSION(:)::TMPICMF
Found Structure @ 34517
SUBROUTINE CONGRAD (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE
C ** GRADIENT SCHEME
C
USE GLOBAL
! *** DSLLC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH
Found Structure @ 34649
SUBROUTINE CONGRADC (ISTL_)
C
C CHANGE RECORD
C ** SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE
C ** GRADIENT SCHEME
C
USE GLOBAL
REAL*8 :: DSTIME
Found Structure @ 34832
SUBROUTINE COSTRAN (ISTL_,IS2TL_,MVAR,M,CON,CON1)
C
C CHANGE RECORD
C ADDED DYNAMIC TIME STEPPING
C ** SUBROUTINE COSTRAN CALCULATES THE ADVECTIVE
C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES
C ** THE NUMBER OF TIME LEVELS IN THE STEP
C
USE GLOBAL
Found Structure @ 35791
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE COSTRANW (ISTL_,IS2TL_,MVAR,M,CON,CON1)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 36701
FUNCTION CSEDRESB(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES BULK EROSION RATE OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY AND OTHER VARIABLES
C ** CURRENT OPTIONS SHOULD NOT BE USED
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
Found Structure @ 36729
FUNCTION CSEDRESS(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES SURFACE EROSION RATE OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
Found Structure @ 36766
FUNCTION CSEDSET(LINDEX,SED,SHEAR,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES CONCENTRATION DEPENDENT SETTLING VELOCITY OF COHESIVE
C ** SEDIMENT
C *** DSLLC BEGIN BLOCK
C
IF(SED.LE.0.0001)THEN
Found Structure @ 36872
FUNCTION CSEDTAUB(DENBULK,TDUM,V1,V2,V3,IOPT)
C
C CHANGE RECORD
C
C
C ** CALCULATES CRITIAL STRESS FOR BULK OR MASS EROSION OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C ** IOPT=1 BASED ON
C **
C ** HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
Found Structure @ 36911
REAL FUNCTION CSEDTAUS(DENBULK,TAUCO,VDRO,VDR,VDRC,IOPT,L)
C
C CHANGE RECORD
C
C#######################################################################
C HQI ADDED, 11/18/2003, HAMRICK COMMENTED OUT SINCE NOT NEEDED FOR
C FOR 11/24 VERSION OF IOPT= 99 THAT IS ACTIVE AS OF 01/08/2004
C#######################################################################
C ** CALCULATES CRITIAL STRESS FOR SURFACE EROSION OF COHESIVE
C ** SEDIMENT AS A FUNCTION OF BED BULK DENSITY
Found Structure @ 36998
REAL FUNCTION CSEDVIS(SED)
C
C CHANGE RECORD
C
C
C ** CALCULATES KINEMATIC VISCOSITY OF HIGH CONCENTRATION COHESIVE
C ** SEDIMENT-WATER MIXTURE BASED ON
C **
C ** MEHTA, A. J., AND F.JIANG, 1990: SOME OBSERVATIONS ON BOTTOM
C ** MUD MOTION DUE TO WAVES. COASTAL AND OCEANOGRAPHIC ENGINEERING
Found Structure @ 37023
FUNCTION CSNDEQC(SNDDIA,SSG,WS,TAUR,TAUB,D50,SIGPHI,
& SNDDMX,IOPT,ISNDAL)
C
C CHANGE RECORD
C
C
C ** CALCULATES NEAR BED REFERENCE CONCENTRATION FOR NONCOHESIVE
C ** SEDIMENT
C ** IOPT=1 BASED ON
C **
Found Structure @ 37090
FUNCTION CSNDSET(SND,SDEN,IOPT)
C
C CHANGE RECORD
C ** CALCULATES HINDERED SETTLING CORRECTION FOR CLASS NS NONCOHESIVE
C ** SEDIMENT
C
ROPT=FLOAT(IOPT)
CSNDSET=(1.-SDEN*SND)**ROPT
RETURN
END
Found Structure @ 37101
FUNCTION CSNDZEQ(SNDDIA,GPDIASED,TAUR,TAUB,SNDDMX,DEP,
& IOPT,SSG,WS)
C
C CHANGE RECORD
C
C
C ** CALCULATES NEAR BED REFERENCE CONCENTRATION REFERENCE HEIGHT
C ** IOPT=1 BASED ON
C **
C ** GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT
Found Structure @ 37152
SUBROUTINE DEPPLT
C
C ** SUBROUTINE DEPPLT WRITES A FILE TO CONTOUR PLOT DEPTH
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*80 TITLE
OPEN(1,FILE='BELVCON.OUT',STATUS='UNKNOWN')
Found Structure @ 37185
MODULE DRIFTER
! *** DRIFTER.F90 IS A LAGRANGIAN PARTICLE TRACKING MODULE FOR THE DYNAMIC SOLUTIONS VERSION OF EFDC (I.E. EFDC_DS)
! *** THIS MODULE COMPLETELY REPLACES THE PREVIOUS VERSIONS OF PARTICLE TRACKING IN EFDC.
! *** THE CARDS C67 AND C68 IN THE EFDC.INP FILE WERE LEFT INTACT TO PROVIDE COMPATIBILITY WITH
! *** OTHER VERSIONS OF EFDC.
USE GLOBAL
IMPLICIT NONE
Found Structure @ 37358
SUBROUTINE DRIFTERINP
! ********************************************************************
!READING INPUT DATA OF INITIAL LOCATIONS OF DRIFTERS
!OUTPUT: NPD,XLA,YLA,ZLA,NP=1:NPD
! LA_BEGTI, LA_ENDTI, LA_FREQ,LANDT
INTEGER(4)::NP,I,J,K
REAL(RKD) ::XC(4),YC(4),AREA2,RANVAL
REAL(8),EXTERNAL::DRAND !IT NEEDS THIS STATEMENT IN CASE OF IMPLICIT NONE
OPEN(ULOC,FILE='DRIFTER.INP',ACTION='READ')
Found Structure @ 37399
SUBROUTINE READSTR(UINP) !******************************************************************
INTEGER(4),INTENT(IN)::UINP
CHARACTER(200)::STR
DO WHILE (1)
READ(UINP,'(A)') STR
STR=ADJUSTL(STR)
IF (STR(1:1).NE.'*') THEN
BACKSPACE(UINP)
RETURN
ENDIF
Found Structure @ 37412
SUBROUTINE CONTAINER(XLA,YLA,ZLA,LLA,KLA,NP) !**********************************************
!DETERMINING LLA,KLA,BELVLA,HPLA FOR THE FIRST CALL
!UPDATING XLA,YLA,LLA,KLA,BELVLA,HPLA FOR THE NEXT CALL
!FOR EACH DRIFTER (XLA,YLA,ZLA)
!BY FINDING THE NEAREST CELL CENTTROID
!THEN EXPANDING TO THE NEIGHBOUR CELLS
!HP(LIJ(I,J)) : WATER DEPTH = WATER SUR. - BELV
!BELV(LIJ(I,J)) : BOTTOM ELEVATION OF A CELL
!BELVLA : BED ELEVATION AT DRIFTER NI POSITION
!HPLA : WATER DEPTH AT DRIFTER NI POSITION
Found Structure @ 37660
SUBROUTINE SET_DRIFTER_OUT
XLA(NI)= XLA1
YLA(NI)= YLA1
ZLA(NI)= ZLA1
LLA(NI)= 1
END SUBROUTINE
END SUBROUTINE
Found Structure @ 37668
SUBROUTINE AREACAL(XC,YC,AREA) ! ***********************************************************
!AREA CALCULATION OF A POLYGON
!WITH GIVEN VEXTICES (XC,YC)
REAL(RKD),INTENT(IN) ::XC(:),YC(:)
REAL(RKD),INTENT(OUT)::AREA
REAL(RKD)::XVEC(2),YVEC(2)
INTEGER(4)::NPOL,K
NPOL = SIZE(XC)
AREA = 0
XVEC(1)=XC(2)-XC(1)
Found Structure @ 37688
SUBROUTINE DRIFVELCAL(LNI,KNI,NI,U1NI,V1NI,W1NI,U2NI,V2NI,W2NI) ! **************************
!CALCULATING VELOCITY COMPONENTS AT DRIFTER LOCATION
!BY USING INVERSE DISTANCE POWER 2 INTERPOLATION
!FOR VELOCITY COMPONENTS AT THE CENTROID OF POLYGON
INTEGER(4),INTENT(IN )::LNI,KNI,NI
REAL(RKD) ,INTENT(OUT)::U1NI,V1NI,W1NI,U2NI,V2NI,W2NI
INTEGER(4)::ICELL,JCELL,I,J,L,LN,K1,K2,KZ1,KZ2
REAL(RKD)::RAD2,SU1,SU2,SU3,SV1,SV2,SV3,SW1,SW2,SW3
REAL(RKD)::UTMPB,VTMPB,UTMPB1,VTMPB1,WTMPB,WTMPB1
REAL(RKD)::VELEK,VELNK,VELEK1,VELNK1,ZSIG
Found Structure @ 37785
SUBROUTINE RANDCAL(L,K,NP) ! ***************************************************************
INTEGER,INTENT(IN)::L,K,NP
REAL(8),EXTERNAL::DRAND
REAL(RKD)::COEF
IF (LA_PRAN==1.OR.LA_PRAN==3) THEN
IF (LA_DIFOP==0) THEN
COEF = SQRT(2*AH(L,K)*DT)
ELSE
COEF = SQRT(2*LA_HORDIF*DT)
ENDIF
Found Structure @ 37808
SUBROUTINE EDGEMOVE(LLA1,NI,ILN,JLN,NCASE,SCALE) ! ****************************************
!I,J,L:INDICES OF DRIFTER AT CURRENT POSITION
INTEGER(4),INTENT(IN)::LLA1,NI,ILN,JLN,NCASE
REAL(RKD), INTENT(IN)::SCALE
REAL(RKD)::UTMPB,VTMPB,VELM
INTEGER(4)::LN,KLA1
KLA1 = KLA(NI)
LN = LNC(LLA1) !
UTMPB = 0.5*STCUV(LLA1)*(RSSBCE(LLA1)*U1(LLA1+1,KLA(NI))+RSSBCW(LLA1)*U1(LLA1,KLA(NI)))
Found Structure @ 37880
SUBROUTINE RESET_LLA(I1,I2,J1,J2)
INTEGER(4),INTENT(IN)::I1,I2,J1,J2
INTEGER(4)::I,J,L
REAL(RKD)::VELEK,VELNK
VELEK =CUE(LLA1)*UTMPB+CVE(LLA1)*VTMPB
VELNK =CUN(LLA1)*UTMPB+CVN(LLA1)*VTMPB
XLA(NI)=XLA1+ DT*VELEK
YLA(NI)=YLA1+ DT*VELNK
DO J=J1,J2
Found Structure @ 37907
FUNCTION INSIDECELL(L,XM,YM) RESULT(INSIDE) ! **********************************************
LOGICAL(4)::INSIDE
INTEGER(4),INTENT(IN)::L
REAL(RKD) ,INTENT(IN)::XM,YM
REAL(RKD) ::XC(6),YC(6),AREA2
XC(1) = XM
YC(1) = YM
XC(2:5)=XCOR(L,1:4)
YC(2:5)=YCOR(L,1:4)
Found Structure @ 37927
SUBROUTINE DRIFTERWDEP(LNI,NI,BELVNI,HPNI) !************************************************
!INTERPOLATION OF THE TOTAL WATER DEPTH AND BOTTOM ELEVATION
!FOR THE DRIFTER NI AT EACH TIME INSTANT AND EACH LOCATION
INTEGER(4),INTENT(IN)::LNI,NI
REAL(RKD),INTENT(OUT)::BELVNI,HPNI
INTEGER(4)::ICELL,JCELL,L,I,J
REAL(RKD) ::BELVNI1,BELVNI2,RAD2,ZETA
ICELL = IL(LNI)
JCELL = JL(LNI)
Found Structure @ 37955
SUBROUTINE DRIFTERLAYER(LNI,NI,BELVNI,HPNI,KLN,ZLN)
!RECALCULATE ZLA(NI)
!DETERMINE KLA(NI)
INTEGER(4),INTENT(IN)::LNI,NI
REAL(RKD), INTENT(IN)::BELVNI,HPNI
INTEGER(4),INTENT(OUT)::KLN
REAL(RKD), INTENT(INOUT)::ZLN
INTEGER(4)::K
REAL(RKD) ::ZSIG
IF (LNI.GE.2) THEN
Found Structure @ 37977
FUNCTION SIGNV(V)
REAL(RKD),INTENT(IN)::V
INTEGER(4)::SIGNV
IF (V>=0) THEN
SIGNV= 1
ELSE
SIGNV=-1
ENDIF
END FUNCTION
Found Structure @ 37987
SUBROUTINE AREA_CENTRD
!DETERMINING CELLCENTROID OF ALL CELLS
!AND CALCULATING THE AREA OF EACH CELL
INTEGER(4)::I,J,K
REAL(RKD)::XC(4),YC(4),AREA2
OPEN(UCOR,FILE='CORNERS.INP',ACTION='READ')
CALL READSTR(UCOR)
ALLOCATE(XCOR(LA,5),YCOR(LA,5),AREA(LA))
XCOR = 0
YCOR = 0
Found Structure @ 38014
END MODULE
REAL*8 FUNCTION DSTIME()
! *** Generic Function to Provide Model Timing
! *** DSTIME returns back the number of seconds since some event
!USE IFPORT
USE IFLPORT
REAL*4::TARR(2), TPMC
REAL*4,STATIC::LASTTIME
! *** CHANGE THE FOLLOWING LINES TO CORRESPOND TO THE PLATORM AND COMPILER
Found Structure @ 38043
SUBROUTINE DUMP
C
C CHANGE RECORD
C ** SUBROUTINE DUMP WRITES FULL FIELD DUMPS OF MODEL VARIABLES
C ** AT SPECIFIED TIME INTERVALS
C
USE GLOBAL
CHARACTER*1 CZTT(0:9)
CHARACTER*1 CCHTMF,CCHTMS
C
CHARACTER*2,ALLOCATABLE,DIMENSION(:)::CNTTOX
Found Structure @ 39548
SUBROUTINE EEXPOUT(JSEXPLORER)
!----------------------------------------------------------------
! ** SUBROUTINE EEXPOUT WRITES BINARY OUTPUT FILES:
! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS
! ** EE_BED - SEDIMENT BED LAYER INFORMATION
! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN
! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION
! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO
Found Structure @ 40156
C
C **********************************************************************
C
PROGRAM EFDC
C
C ** WELCOME TO THE ENVIRONMENTAL FLUID DYNAMICS COMPUTER CODE SERIES
C ** DEVELOPED BY JOHN M. HAMRICK. THE EFDC CODE WAS ORGINALLY
C ** DEVELOPED AT VIRGINIA INSTITUTE OF MARINE SCIENCE
C ** /SCHOOL OF MARINE SCIENCE, THE COLLEGE OF
C ** WILLIAM AND MARY, GLOUCESTER POINT, VA 23062
C ** THIS SOURCE FILE IS A DIRECT RELEASE BY THE DEVELOPER
Found Structure @ 42277
FUNCTION FDSTRSE(VOID,BMECH1,BMECH2,BMECH3)
C
C CHANGE RECORD
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C
C
C ** FDSTRSE IS COMPRESSION LENGTH SCALE
C STRESS WITH RESPECT TO VOID RATIO
C
IF(BMECH1.GT.0.0)THEN
Found Structure @ 42303
FUNCTION FHYDCN(VOID,BMECH4,BMECH5,BMECH6,IBMECHK)
C
C CHANGE RECORD
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C
C
C ** FHYDCN IS HYDRAULIC CONDUCTIVITY DIVIDED BY 1+VOID RATIO
C
IF(BMECH4.GT.0.0)THEN
TMP=(VOID-BMECH5)/BMECH6
Found Structure @ 42326
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE FOODCHAIN(IFINISH)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 43060
FUNCTION FSBDLD(DIASED,GPDIASED,D50,DEP,PEXP,PHID,CSHIELDS,
& SBDLDP,ISOPT)
C
C CHANGE RECORD
C MODIFED TO INCLUDE ALTERNATE FORMULAS FOR BED LOAD PHI
C
C
C ** CALCULATES DIMNSIONLESS BED LOAD TRANSPORT COEFFICIENT
C ** ISOPT=0 USE CONSTANT VALUE
C
IF(ISOPT.EQ.0) FSBDLD=SBDLDP
Found Structure @ 43102
FUNCTION FSEDMODE(WS,USTOT,USGRN,RSNDM,ISNDM1,ISNDM2,IMODE)
C
C ** FSEDMODE SETS BEDLOAD (IMODE=1) AND SUSPENDED LOAD (IMODE=2)
C ** TRANSPORT FRACTIONS
C
C
C CHOOSE BETWEEEN TOTAL STRESS SHEAR VELOCITY AND GRAIN STRESS
C SHEAR VELOCITY
C
Found Structure @ 43177
FUNCTION FSTRSE(VOID,BMECH1,BMECH2,BMECH3)
C
C ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C CHANGE RECORD
C
C
C ** FSTRSE IS WATER SPECIFIC WEIGHT NORMALIZED EFFECTIVE STRESS
C
IF(BMECH1.GT.0.0)THEN
TMP=-(VOID-BMECH2)/BMECH3
FSTRSE=BMECH1*EXP(TMP)
Found Structure @ 43198
FUNCTION FUNDEN(SAL,SED,TEM)
C
C ** FUNDEN CALCULATED DENSITY AS A FUNTION OF SAL,TEM,AND SED
C CHANGE RECORD
C IMPLICIT REAL*8 (A-H,O-Z)
C
REAL TTMP,SSG,SDEN,SSTMP,RHTMP,RHO
SSG=2.5
SDEN=1./2500000.
Found Structure @ 43231
SUBROUTINE HDMT
C
C ** SUBROUTINE HDMT EXECUTES THE FULL HYDRODYNAMIC AND MASS TRANSPORT
C ** TIME INTERGATION
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C----------------------------------------------------------------------C
C
C CHANGE RECORD
Found Structure @ 44872
SUBROUTINE HDMT2T
C
C ** SUBROUTINE HDMT2T EXECUTES THE FULL HYDRODYNAMIC AND MASS
C ** TRANSPORT TIME INTERGATION USING A TWO TIME LEVEL SCHEME
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION
C
C----------------------------------------------------------------------C
C
C CHANGE RECORD
C DATE MODIFIED BY DATE APPROVED BY
Found Structure @ 46801
SUBROUTINE INITBIN
C
C**********************************************************************C
C
C M.R. MORTON 23 JUL 1998
C
C ** LAST MODIFIED BY JOHN HAMRICK AND MIKE MORTON ON 8 AUGUST 2001
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 47237
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE INITBIN2
C
C**********************************************************************C
C
C M.R. MORTON 01 APR 1999
C
Found Structure @ 47485
SUBROUTINE INITBIN3
C
C M.R. MORTON 29 APR 1999
C CHANGE RECORD
C INITIALIZES BINARY FILE FOR EFDC OUTPUT. PLACES CONTROL
C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY
C FILE WQDOCOMP.BIN FOR D.O. COMPONENT ANALYSIS.
C
USE GLOBAL
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT
Found Structure @ 47754
SUBROUTINE INITBIN4
C
C M.R. MORTON 02 JUN 1999
C CHANGE RECORD
C INITIALIZES BINARY FILE FOR EFDC OUTPUT. PLACES CONTROL
C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY
C FILE WQSDTS.BIN FOR BENTHIC FLUX RATES.
C
USE GLOBAL
Found Structure @ 47951
SUBROUTINE INPUT(TITLE)
C
C ** SUBROUTINE INPUT READS ALL INPUT DATA EXCEPT DATA IN LXLY.INP,
C ** MASK.INP AND RESTART.INP
C CHANGE RECORD
C ADDED BODY FORCE SWITCH ISBODYF (C14) AND READ OF INPUT FILE
C FBODY.INP CONTAINING THE BODY FORCE FBODYFX AND FBODYFY
C MODIFIED BED MECHANICS COEFFICIENT SET ON (C38)
C MODIFIED BEDLOAD FUNCTIONAL RELATIONSHIP TO MORE GENERAL FORM (C42A)
C ADDED BEDLOAD OUTFLOW/RECIRCULATION BOUNDARY CONDTION SWITCH (C42A)
Found Structure @ 52537
! *** DSLLC UTIL
FUNCTION PARSE_REAL(INLINE)
CHARACTER*(*) INLINE
CHARACTER*15 CVAL,TMPVAL
ILEN=LEN_TRIM(INLINE)
PARSE_REAL=0.
DO IC=1,ILEN
IF(INLINE(IC:IC).EQ.':')THEN
Found Structure @ 52567
FUNCTION PARSE_LOGICAL(INLINE)
CHARACTER*(*) INLINE
CHARACTER*12 CVAL
LOGICAL PARSE_LOGICAL
ILEN=LEN_TRIM(INLINE)
DO IC=1,ILEN
IF(INLINE(IC:IC).EQ.':')THEN
DO IPOS=IC+1,ILEN
Found Structure @ 52598
SUBROUTINE JPEFDC
C
C ** PROGRAM JPEFDC IS STAND ALONE VERSION OF EFDC JET-PLUME MODEL
C ** BASED ON LEE AND CHEUNG'S LAGRANGIAN BUOYANT JET MODEL
C ** AND EXTENDED FOR THREE-DIMENSIONAL AMBIENT CURRENTS
C ** REF: LEE, J.H.W., AND V. CHEUNG, J. ENVIRON. ENGR., 116, 1085-
C ** 1106, 1990.
C ** FOR MORE INFO EMAIL [email protected]
C CHANGE RECORD
C
USE GLOBAL
Found Structure @ 54348
SUBROUTINE LSQHARM
C
C CHANGE RECORD
C ** SUBROUTINE LSQHARM PERFORMS A LEAST SQUARES HARMONIC ANALYSIS
C
USE GLOBAL
CHARACTER*80 TITLE,TITNT,TITRT
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::AMATMP
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PPPTMP
Found Structure @ 55236
SUBROUTINE LUBKSB(A,N,NP,INDX,B)
C
C CHANGE RECORD
C
DIMENSION A(NP,NP),B(N),INDX(N)
C
II=0
DO 12 I=1,N
LL=INDX(I)
SUM=B(LL)
Found Structure @ 55268
SUBROUTINE LUDCMP(A,N,NP,INDX,D)
C
C CHANGE RECORD
C
PARAMETER (TINY=1.0E-20)
DIMENSION A(NP,NP),INDX(N)
REAL,ALLOCATABLE,DIMENSION(:)::VV
ALLOCATE(VV(N))
C
D=1.
I am going to copy
Found Structure @ 55336
SUBROUTINE NEGDEP(QCHANUT,QCHANVT,ISTL_)
C
C CHANGE RECORD
C ADDED ALTERNATE SOR EQUATION SOLVER RELAX2T
C ** SUBROUTINE NEGDEP CHECK EXTERNAL SOLUTION FOR NEGATIVE DEPTHS
C
USE GLOBAL
DIMENSION QCHANUT(NCHANM),QCHANVT(NCHANM)
C
C ** CHECK FOR NEGATIVE DEPTHS
Found Structure @ 55510
SUBROUTINE OUT3D
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER *11 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN,
& CMPFN,SNDFN,TOXFN
REAL,ALLOCATABLE,DIMENSION(:,:)::AKL
REAL,ALLOCATABLE,DIMENSION(:,:)::AIJ
Found Structure @ 56886
SUBROUTINE OUTPUT1
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** PLOT SURFACE ELEVATION
C
DO L=2,LA
PAM(L)=P(L)*GI
Found Structure @ 57040
SUBROUTINE OUTPUT2
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** OUTPUT RESULTS OF RELAXATION SOLUTION
C
WRITE (7,40) RP
40 FORMAT (1H1,' RESULTS OF RELAX SOLUTION - RP=',F5.2,//)
Found Structure @ 57098
SUBROUTINE PPLOT (IPT)
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER BLANK,ASTER,LET1(51),LET2(51)
DIMENSION BNDU(51),BNDL(51)
CHARACTER*1,ALLOCATABLE,DIMENSION(:,:)::CHARY
DATA BLANK/' '/
DATA ASTER/'*'/
Found Structure @ 57188
SUBROUTINE QUIT
INTERFACE TO FUNCTION GETCH
& [C,ALIAS:'__getch']
& ()
CHARACTER GETCH*1
END
CHARACTER KEY*1
WRITE(*,'(''TAP SPACEBAR TO EXIT''\)')
KEY=GETCH()
RETURN
Found Structure @ 57200
SUBROUTINE RCAHQ
C
C CHANGE RECORD
C ** SUBROUTINE FOR INTERFACING RCA MODEL
C ** MODIFIED FROM WCA2A PROUDCTION VERSION
C ** WITH WITHDRAWL-RETURN FLOW OPTION DEACTIVATED BY CNWR
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 57945
SUBROUTINE RELAX2T
C
C CHANGE RECORD
C ADDED THIS SUBROUTINE RELAX2T
C ** SUBROUTINE RELAX SOLVES THE FINITE DIFFERENCE FORM
C ** OF A PSEUDO HEMHOLTZ EQUATION
C **
C ** CS(L)*P(LS)+CW(L)*P(L-1)
C ** +CC(L)*P(L)+CE(L)*P(L+1)
C **
Found Structure @ 58033
SUBROUTINE RESTIN1
C
C CHANGE RECORD
C ADDED CODE TO PROPERLY INITIAL RESTART INPUT FOR DRYING AND WETTING
C ** SUBROUTINE RESTIN1 READS A RESTART FILE
C
USE GLOBAL
REAL,ALLOCATABLE,DIMENSION(:)::TDUMMY
ALLOCATE(TDUMMY(KCM))
Found Structure @ 58696
SUBROUTINE RESTIN10
C
C CHANGE RECORD
C ** SUBROUTINE RESTINP READS A RESTART FILE GENERATED BY A
C ** PRE SEPTEMBER 8, 1992 VERSION OF EFDC.FOR
C
USE GLOBAL
PRINT *,'READING RESTIN10 FILE: RESTART.INP'
OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN')
Found Structure @ 58989
SUBROUTINE RESTIN2
C
C CHANGE RECORD
C ** SUBROUTINE RESTINP READS A RESTART FILE FOR (KC/2) LAYERS AND
C ** AND INITIALIZES FOR KC LAYERS
C
USE GLOBAL
PRINT *,'READING RESTIN2 FILE: RESTART.INP'
OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN')
Found Structure @ 59198
SUBROUTINE RESTMOD
C
C CHANGE RECORD
C ** SUBROUTINE RESTOUT WRITES A RESTART FILE
C
USE GLOBAL
DIMENSION LIJMOD(100)
OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN')
Found Structure @ 59304
SUBROUTINE RESTOUT(IRSTYP)
C
C CHANGE RECORD
C 11/14/2001 JOHN HAMRIC 11/14/2001 JOHN HAMRIC
C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY
C ** SUBROUTINE RESTOUT WRITES A RESTART FILE
C
USE GLOBAL
IF(IRSTYP.EQ.0)THEN
Found Structure @ 59792
SUBROUTINE ROUT3D
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER *12 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN,
& CMPFN,SNDFN,TOXFN
REAL,ALLOCATABLE,DIMENSION(:,:)::AIJ
Found Structure @ 61176
SUBROUTINE RSALPLTH(ICON,CONC)
C
C CHANGE RECORD
C ** SUBROUTINE RSALPLTH WRITES FILES FOR RESIDUAL SCALAR FIELD
C ** CONTOURING IN HORIZONTAL PLANES
C
USE GLOBAL
DIMENSION DBS(10)
CHARACTER*80 TITLE
DIMENSION CONC(LCM,KCM)
Found Structure @ 61489
SUBROUTINE RSALPLTV(ITMP)
C
C CHANGE RECORD
C ** SUBROUTINE RSALPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF RESIDUAL SALINITY AND VERTICAL DIFFUSIVITY ALONG AN ARBITARY
C ** SEQUENCE OF (I,J) POINTS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 61998
SUBROUTINE RSMICI(ISMTICI)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INSMICI).
C
USE GLOBAL
CHARACTER TITLE(3)*79,ICICONT*3
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XSMPOC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XSMPON
Found Structure @ 62075
SUBROUTINE RSMRST
C
C CHANGE RECORD
C READ ICS FROM RESTART FILE FROM INSMRST.
C
USE GLOBAL
LOGICAL FEXIST
C
C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE
C THE ASCII FILE INSTEAD.
Found Structure @ 62122
SUBROUTINE RSURFPLT
C
C CHANGE RECORD
C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE
C ** ELEVATION
C
USE GLOBAL
CHARACTER*80 TITLE
IF(JSRPPH.NE.1) GOTO 300
OPEN(10,FILE='RSURFCN.OUT',STATUS='UNKNOWN')
Found Structure @ 62165
SUBROUTINE RVELPLTH
C
C CHANGE RECORD
C ** SUBROUTINE RVELPLTH WRITES HORIZONTAL EULERIAN RESIDUAL, VECTOR
C ** POTENTIAL AND MEAN MASS TRANSPORT VELOCITY VECTOR FILES
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
DIMENSION DBS(10)
Found Structure @ 62266
SUBROUTINE RVELPLTV
C
C CHANGE RECORD
C ** SUBROUTINE VELPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF VELOCITY NORMAL TO AN ARBITARY SEQUENCE OF (I,J) POINTS AND
C ** AND VERTICAL PLANE TANGENTIAL-VERTICAL VELOCITY VECTORS
C
USE GLOBAL
CHARACTER*80 TITLE10,TITLE20,TITLE30
Found Structure @ 62827
SUBROUTINE RWQAGR(IWQTAGR)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR ALGAL
C GROWTH, RESP. & PREDATION RATES, AND BASE LIGHT EXTINCT. COEFF.
C (UNIT INWQAGR).
C
USE GLOBAL
CHARACTER TITLE(3)*79, AGRCONT*3
OPEN(1,FILE=AGRFN,STATUS='UNKNOWN')
Found Structure @ 62874
SUBROUTINE RWQATM
C
C CHANGE RECORD
C ** COMPUTES WET ATMOSPHERIC DEPOSITION USING CONSTANT CONCENTRATIONS
C ** FOR THE 22 STATE VARIABLES MULTIPLIED BY THE RAINFALL FLOW RATE !VB CHANGED 21 TO 22
C ** ENTERING EACH GRID CELL. COMPUTED LOADS ARE IN G/DAY.
C
USE GLOBAL
C
C CV2 = CONVERSION TO GET UNITS OF G/DAY
Found Structure @ 62917
SUBROUTINE RWQBEN2 (TIMTMP)
C
C M. MORTON 01/30/98: CHANGED CODE TO ALLOW FOR TEMPORALLY
C VARYING BENTHIC FLUXES IN THE BENFN FILE. PREVIOUS VERSION ONLY
C PROVIDED SPATIALLY VARYING FLUX (NO PROVISION FOR TIME VARYING).
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR BENTHIC
C FLUXES OF PO4D, NH4, NO3, SAD, COD, O2
C FORMAT OF BENFN FILE IS:
C TITLE 1
Found Structure @ 63038
SUBROUTINE RWQC1
C
C CHANGE RECORD
C READ IN FROM THE UNIT #8
C: I/O CONTROL VARIABLES
C: SPATIALLY AND TEMPORALLY CONSTANT REAL PARAMETERS
C
USE GLOBAL
C
IMPLICIT NONE
Found Structure @ 64872
SUBROUTINE RWQCSR
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
CHARACTER*11 FNWQSR(40)
CHARACTER*2 SNUM
Found Structure @ 64950
SUBROUTINE RWQICI
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INWQICI).
C
USE GLOBAL
CHARACTER TITLE(3)*79, ICICONT*3
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XWQV
IF(.NOT.ALLOCATED(XWQV))THEN
ALLOCATE(XWQV(NWQVM))
Found Structure @ 65023
C ***
C *** READ IN TEMPORALLY VARYING POINT SOURCE INPUT (UNIT INWQPSL).
C *** INPUT UNITS (KG/D) EXCEPT: TAM(KMOL/D), FCB(MPN/D).
C *** COMPUTATIONAL UNITS, WQ CONSTITUENT LOADS ARE IN G/DAY,
C *** EXCEPT TAM IN (MOL/D) & FCB IN (MPN/D).
C
SUBROUTINE RWQPSL
C
C CHANGE RECORD
C
Found Structure @ 65237
SUBROUTINE RWQRST
C
C CHANGE RECORD
C READ ICS FROM RESTART FILE FROM INWQRST.
C
USE GLOBAL
LOGICAL FEXIST
C
C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE
C THE ASCII FILE INSTEAD.
Found Structure @ 65297
SUBROUTINE RWQSTL(IWQTSTL)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR SETTLING
C VELOCITIES OF ALGAE, RPOM, LPOM & PARTICULATE METAL (UNIT INWQSTL).
C ALSO SPATIALLY/TEMPORALLY VARYING REAERATION ADJUSTMENT FACTOR.
C
C
C *** WQWSC = Settling velocity for cyanobacteria (m/day)
C *** WQWSD = Settling velocity for algae diatoms (m/day)
Found Structure @ 65351
C
C READ IN TEMPORALLY VARYING PARAMETERS FOR DAILY SOLAR RADIATION (WQI0)
C AND FRACTIONAL DAYLENGTH (WQFD) (UNIT INWQSUN).
C
SUBROUTINE RWQSUN
C
C ** NEW VERSION BY J. M. HAMRICK 7 APRIL 1997
C CHANGE RECORD
C ** READS AND INTERPOLATES DAILY AVERAGE SOLAR RADIATION AND
C ** DAYLIGHT FRACTION
Found Structure @ 65429
SUBROUTINE BEDLOADJ
USE GLOBAL
IMPLICIT NONE
INTEGER::I,J,L,K
!PT: real values are written in DOUBLE PRECISION 7/16/08.
DOUBLE PRECISION,DIMENSION(LCM)::VELMAG
!
! University of California, Santa Barbara
! Craig Jones and Wilbert Lick
!
Found Structure @ 65544
!**********************************************************************!
SUBROUTINE SEDZLJ_MAIN
USE GLOBAL
IMPLICIT NONE
DOUBLE PRECISION,DIMENSION(LCM)::WVEL,CLEFT,CRIGHT,GRADSED,SEDAVG,CRNUM,CRAIG
INTEGER::L,K,NS
DOUBLE PRECISION::AA11,AA12,AA21,AA22,BB11,BB22,DETI
! PT: real values are written in DOUBLE PRECISION. 7/16/08
!**********************************************************************!
!
! ** SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
Found Structure @ 65993
SUBROUTINE MORPHJ
! REVISION DATE : May 24, 2006
! Craig Jones and Scott James
!***************************************************************
USE GLOBAL
IMPLICIT NONE
!REAL::TMPVAL
!INTEGER::ITMP,K,L,LL,NS,NT
!REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED
DOUBLE PRECISION::TMPVAL
Found Structure @ 66068
SUBROUTINE SEDIC
USE GLOBAL
IMPLICIT NONE
INTEGER::CORE,I,INCORE,J,L,LL,M,K,NS,VAR_BED,NSCICM,FDIR,NWV
INTEGER::IWV,JWV,NSKIP
CHARACTER(LEN=80)::STR_LINE
!PT- real values are written in DOUBLE PRECISION. 7/16/08
DOUBLE PRECISION::BLKTMP,STWVHTMP,STWVTTMP,STWVDTMP
DOUBLE PRECISION,DIMENSION(10)::PTEMP
DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::BDEN !(INCORE,KB)
DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::TAUTEMP !(KB)
Found Structure @ 66410
SUBROUTINE SEDZLJ(L)
USE GLOBAL
IMPLICIT NONE
INTEGER::KK,LL,K,L
INTEGER::NSC0,NSC1,NTAU0,NTAU1
DOUBLE PRECISION::WDTDZ,SURFACE
DOUBLE PRECISION::SN00
DOUBLE PRECISION::SN01
DOUBLE PRECISION::SN10
DOUBLE PRECISION::SN11
Found Structure @ 66784
SUBROUTINE SEDZLJ_SHEAR
USE GLOBAL
IMPLICIT NONE
INTEGER::L
INTEGER::M1,M2
INTEGER::FZONE
!PT: All real values are explicitly written in DOUBLE PRECISION 7/16/08.
DOUBLE PRECISION::TEMP,MMW,SIGMAWV,JJW
Found Structure @ 67016
SUBROUTINE SALPLTH (ICON,CONC)
C
C CHANGE RECORD
C ** SUBROUTINE SALPLTH WRITES FILES FOR INSTANTANEOUS SCALAR FIELD
C ** CONTOURING IN HORIZONTAL PLANES
C
USE GLOBAL
DIMENSION DBS(10)
CHARACTER*80 TITLE
DIMENSION CONC(LCM,KCM)
Found Structure @ 67584
SUBROUTINE SALPLTV(ITMP)
C
C CHANGE RECORD
C ** SUBROUTINE SALPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF SALINITY, DYE CONCENTRATION, AND SEDIMENT CONCENTRATION
C ** ALONG AN ARBITARY SEQUENCE OF (I,J) POINTS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 68272
SUBROUTINE SALTSMTH
C
C CHANGE RECORD
C
USE GLOBAL
IF(NSBMAX.GT.10) GOTO 1001
C
C ELSE
C GOTO 1001
C
Found Structure @ 68362
SUBROUTINE SCANASER
USE GLOBAL
CHARACTER*120 LIN
WRITE(*,'(A)')'SCANNING INPUT FILE: ASER.INP'
OPEN(1,FILE='ASER.INP',STATUS='OLD')
DO N=1,NASER
10 READ(1,*,ERR=10,END=40)M,R,R,I,R,R,R,R
READ(1,*,ERR=20,END=40)I,R,R,R,R,R,R,R,R,R
NDASER=MAX(NDASER,M)
Found Structure @ 68404
SUBROUTINE SCANDSER(NCSER3)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: DSER.INP'
OPEN(1,FILE='DSER.INP',STATUS='OLD')
DO NS=1,NCSER3
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO I=1,M
Found Structure @ 68434
SUBROUTINE SCANEFDC(NCSER1,NCSER2,NCSER3,NCSER4)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: EFDC.INP'
OPEN(1,FILE='EFDC.INP',STATUS='OLD')
CALL SEEK('C4')
READ(1,*,ERR=10) ISLTMT,ISSSMMT,ISLTMTS,ISIA,RPIA,RSQMIA,
& ITRMIA,ISAVEC
Found Structure @ 68643
SUBROUTINE SCANGWSR
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: GWSER.INP'
OPEN(1,FILE='GWSER.INP',STATUS='OLD')
10 READ(1,*,ERR=10,END=40)NGWSER
NGWSERM=MAX(1,NGWSER)
DO NS=1,NGWSER
READ(1,*,ERR=20,END=40)M,R,R,R,R
NDGWSER=MAX(NDGWSER,M)
DO I=1,M
Found Structure @ 68668
SUBROUTINE SCANMODC
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: MODCHAN.INP'
OPEN(1,FILE='MODCHAN.INP',STATUS='OLD')
10 READ(1,*,ERR=10,END=40)M,I,I
NCHANM=MAX(1,M)
READ(1,*,ERR=20,END=40)I,I,R
CLOSE(1)
RETURN
20 WRITE(*,30)
Found Structure @ 68687
SUBROUTINE SCANPSER
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: PSER.INP'
OPEN(1,FILE='PSER.INP',STATUS='OLD')
DO NS=1,NPSER
10 READ(1,*,ERR=10,END=40)M,R,R,R,R
NDPSER=MAX(NDPSER,M)
DO I=1,M
READ(1,*,ERR=20,END=40)R,R
ENDDO
Found Structure @ 68711
SUBROUTINE SCANQCTL
USE GLOBAL
CHARACTER*80 SKIP
CHARACTER*10 INFILE
WRITE(*,'(A)')'SCANNING INPUT FILE: QCTL.INP'
INFILE='QCTL.INP'
OPEN(1,FILE='QCTL.INP',STATUS='UNKNOWN')
! *** FIND THE MAXIMUM NUMBER OF TABLE DATA POINTS
Found Structure @ 68752
SUBROUTINE SCANQSER
USE GLOBAL
INTEGER*4 NS, I, J, M
WRITE(*,'(A)')'SCANNING INPUT FILE: QSER.INP'
OPEN(1,FILE='QSER.INP',STATUS='OLD')
DO NS=1,NQSER
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R,J
NDQSER=MAX(NDQSER,M)
IF(I.EQ.1)THEN
Found Structure @ 68785
C *****************************************************************************
SUBROUTINE SCANQWSER
USE GLOBAL
INTEGER*4 NTMP, I, J, M, NV
NTMP=4+NSED+NSND+NTOX
! *** Handle Water Quality variables, if needed
IF(ISTRAN(8).GT.0)THEN
WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP (PRELIM)'
Found Structure @ 68836
SUBROUTINE SCANSEDZLJ
!
! REVISION DATE : May 24, 2006
! Craig Jones and Scott James
!***************************************************************
USE GLOBAL
IMPLICIT NONE
INTEGER::IDUMMY,ERROR
!
WRITE(*,'(A)')'SCANNING INPUT FILE: BED.SDF'
OPEN(1,FILE='BED.SDF',STATUS='OLD')
Found Structure @ 68874
SUBROUTINE SCANSFSR(NCSER4)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: SFSER.INP'
OPEN(1,FILE='SFSER.INP',STATUS='OLD')
DO NS=1,NCSER4
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68904
SUBROUTINE SCANSSER(NCSER1)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: SSER.INP'
OPEN(1,FILE='SSER.INP',STATUS='OLD')
DO NS=1,NCSER1
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68934
SUBROUTINE SCANTSER(NCSER2)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: TSER.INP'
OPEN(1,FILE='TSER.INP',STATUS='OLD')
DO NS=1,NCSER2
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68964
SUBROUTINE SCANWQ
! *** Merged SNL & DS-INTL Codes
USE GLOBAL
CHARACTER*10 INFILE
CHARACTER*2 SNUM
CHARACTER*120 LINE
CHARACTER*11 FNWQSR(40)
Found Structure @ 69103
SUBROUTINE SCANWSER
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: WSER.INP'
OPEN(1,FILE='WSER.INP',STATUS='OLD')
DO NS=1,NWSER
10 READ(1,*,ERR=10,END=40)M,R,R,R,I
NDWSER=MAX(NDWSER,M)
DO I=1,M
READ(1,*,ERR=20,END=40)R,R,R
ENDDO
ENDDO
Found Structure @ 69125
SUBROUTINE SCNTXSED
USE GLOBAL
CHARACTER*80 SKIP
CHARACTER*10 INFILE
! *** NOW FIND MAX FOR TOXICS AND SEDIMENTS
DO N=1,3
NCSERNC=0
IF(N.EQ.1)THEN
Found Structure @ 69208
FUNCTION SEDFLUX(SMSOD1)
C
C SOLVE MASS-BALANCE EQ'S FOR NH4, NO3 & H2S/CH4 AND THEIR FLUXES.
C
USE GLOBAL
RSMSS = SMSOD1 / (SMO20+ 1.E-18)
C
C NH4
C
RRNH4 = SK1NH4SM/(RSMSS+ 1.E-18)
A11NH4 = RSMSS*SMFD1NH4 + A1NH4SM + RRNH4
Found Structure @ 69272
SUBROUTINE SEEK(TAG)
C
CHARACTER TAG*(*)
CHARACTER*80 TEXT
C
L=LEN(TAG)
DO I=1,L
J=ICHAR(TAG(I:I))
IF(97.LE.J.AND.J.LE.122)THEN
TAG(I:I)=CHAR(J-32)
Found Structure @ 69311
SUBROUTINE SETBCS
C
C CHANGE RECORD
C MODIFIED BOUNDARY CONDITION FLAGS FOR TYPE 2 OPEN BOUNDARIES
C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L)
C TO MODIFIED CALCULATION OF CELL CENTER BED STRESS (STORED AS QQ(L,0))
C AND THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/SINKS
C ** SUBROUTINE SETBCS SETS BOUNDARY CONDITION SWITCHES
C
USE GLOBAL
Found Structure @ 70176
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE SETFPOCB(ITYPE)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 70446
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE SETOBC2T(DE_T,D_LTD2,DE_TI)
C
C TT Version (Only used with TT versions of CALPUV)
C
C CHANGE RECORD
C
Found Structure @ 70596
SUBROUTINE SETOPENBC(DE_T,D_LTD2,DE_TI,HUT,HVT)
C
C CHANGE RECORD
C ** SUBROUTINE SETOBC SETS OPEN BOUNDARY CONDITIONS FOR
C CALPUV2T & CALPUV2C AND CALPUV9 & CALPUV9C
C
C *** MODIFIED BY PAUL M. CRAIG TO ADDRESS MOVING CALL IN CALPUV2#
C
USE GLOBAL
C
Found Structure @ 70760
SUBROUTINE SETOPENBC2
C
C CHANGE RECORD
C ** SUBROUTINE SETOBC SETS OPEN BOUNDARY CONDITIONS FOR
C CALPUV2T & CALPUV2C AND CALPUV9 & CALPUV9C
C
C *** MODIFIED BY PAUL M. CRAIG
C
USE GLOBAL
C
Found Structure @ 70806
SUBROUTINE SETSHLD(TSC,THETA,D,SSG,DSR,USC)
C
C CHANGE RECORD
C
C
C ** NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C ** USING VAN RIJN'S EQUATIONS
C
VISC=1.E-6
GP=(SSG-1.)*9.82
TMP=GP/(VISC*VISC)
Found Structure @ 70841
FUNCTION SETSTVEL(D,SSG)
C
C CHANGE RECORD
C
C
C ** NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C ** USING VAN RIJN'S EQUATIONS
C
VISC=1.E-6
GP=(SSG-1.)*9.82
Found Structure @ 70871
SUBROUTINE SHOWVAL
! *** REWRITTEN BY PAUL M. CRAIG ON DEC 2006
! ***
! *** 2010_06 CHANGED THE NSHTYPE TO CORRESPOND TO PARAMETER LIST
USE GLOBAL
CHARACTER BLANK,ASTER,CSURF(32),CSALS(20),CSALB(20)
CHARACTER UNITS*3, PARM*3, CSUB*1
SAVE INFODT, JSHPRT, UNITS, SCALE, PARM
Found Structure @ 71123
SUBROUTINE SKIPCOMM(IUNIT, CC)
C
C CHANGE RECORD
C SKIPS OVER COMMENT LINES IN INPUT FILES
C
CHARACTER CC*1, LINE*120
100 READ(IUNIT, 8, END=999) LINE
WRITE(2,9)LINE
IF(LINE(1:1) .EQ. CC) GOTO 100
IF(LINE(1:1) .EQ. 'C') GOTO 100
IF(LINE(1:1) .EQ. 'c') GOTO 100
Found Structure @ 71139
SUBROUTINE SMINIT
C
C CHANGE RECORD
C
USE GLOBAL
SMTSNAME(1) = 'SOM'
SMTSNAME(2) = 'SIM'
SMTSNAME(3) = 'SBF'
DO L=2,LA
SMHYST(L)=.FALSE.
Found Structure @ 71153
SUBROUTINE SMMBE
C
C CHANGE RECORD
C CONTROL SUBROUTINE FOR SEDIMENT COMPONENT OF WATER QUALITY MODEL
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C AND BFSADSUM ARRAYS TO KEEP TRACK OF BENTHIC FLUXES AT ALL CELLS
C FOR LATER STORAGE IN BINARY FILE (WQSDTS.BIN).
C
USE GLOBAL
Found Structure @ 71497
SUBROUTINE SMRIN1()
C
C CHANGE RECORD
C
USE GLOBAL
PARAMETER (SMCW2=2.739726E-5) ! *** cm/y to m/day
CHARACTER TITLE(3)*79, CCMRM*1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SMKPOC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SMKPON
Found Structure @ 72088
SUBROUTINE SOLVSMBE(SMV1,SMV2,SMA11,SMA22,SMA1,SMA2,SMB11,SMB22)
C
C SOLVE 2X2 MATRIX
C CHANGE RECORD
C
SMA12 = -SMA2
SMA21 = -SMA1
SMDET = SMA11*SMA22 - SMA12*SMA21
IF(SMDET.EQ.0.0)THEN
PRINT*, 'SINGULAR MATRIX: A11, A12, A21, A22, B11, B22'
PRINT*, SMA11,SMA12,SMA21,SMA22,SMB11,SMB22
Found Structure @ 72106
SUBROUTINE SSEDTOX(ISTLX,IS2TLX,CORDTX)
C
C CHANGE RECORD
C CHANGED ADD AND REMOVE BED LAYER ALGORITHM - SEE SECTIONS UNDER
C IBMECH=0,1, AND GE 2
C CHANGED ADD AND REMOVE BED LAYER ALGORITHM - SEE SECTIONS UNDER
C IBMECH=0,1, AND GE 2
C MODIFIED NONCOHESIVE RESUSPENSION FORMULATION TO BE CONSISTENT
C WITH ADD AND REMOVE BED LAYER MODIFICATION
C ADDED NONCOHESIVE BEDLOAD-SUSPENDED LOAD DISTRIBUTION FACTOR
Found Structure @ 73231
SUBROUTINE SUBCHAN(QCHANUT,QCHANVT,IACTIVE,RLAMN,RLAMO,DE_T,
& IACTALL)
C
C CHANGE RECORD
C ** SUBROUTINE SUBCHAN CALCULATES SUBGRID CHANNEL INTERACTIONS AND IS
C ** CALLED FROM CALPUV2TC
C
USE GLOBAL
DIMENSION IACTIVE(NCHANM),QCHANUT(NCHANM),QCHANVT(NCHANM)
C
Found Structure @ 73368
SUBROUTINE SURFPLT
C
C CHANGE RECORD
C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE
C ** ELEVATION
C
USE GLOBAL
CHARACTER*80 TITLE
C
C *** EE BEGIN BLOCK
Found Structure @ 73478
SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
C
C ** FROM NUMERICAL RECIPES
C CHANGE RECORD
C
DIMENSION U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP)
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMP
IF(.NOT.ALLOCATED(TMP))ALLOCATE(TMP(N))
C
DO 12 J=1,N
Found Structure @ 73508
SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
C
C ** FROM NUMERICAL RECIPES
C CHANGE RECORD
C
DIMENSION A(MP,NP),W(NP),V(NP,NP)
REAL,ALLOCATABLE,DIMENSION(:)::RV1
ALLOCATE(RV1(N))
G=0.0
SCALE=0.0
Found Structure @ 73749
SUBROUTINE TECPLOT
!
! Tecplot customized output
! Calculate shear stress here even for non-sediment cases
!
! CALL SEDZLJ_SHEAR
!
! REVISION DATE: May 24, 2006
! Craig Jones and Scott James
Found Structure @ 73888
SUBROUTINE TIMELOG(N,TIMEDAY)
CHARACTER*8 MRMDATE,MRMTIME*10
C
C WRITE OUT MODEL TIME STEP AND SUN/PC SYSTEM CLOCK TIME TO TIME.LOG FIL
C
! *** WRITE OUT MODEL TIME STEP AND SYSTEM CLOCK TIME TO TIME.LOG
CALL DATE_AND_TIME(MRMDATE,MRMTIME)
WRITE(9,100)N,TIMEDAY,MRMDATE,MRMTIME
100 FORMAT(' ','N =',I10,5X,'TIMEDAY = ',F12.4,5X,'DATE = ',A8,
& 5X,'TIME = ',A10)
RETURN
Found Structure @ 73900
SUBROUTINE TMSR
C
C CHANGE RECORD
C CHANGED TOX BED OUTPUT
C ** SUBROUTINE TMSR WRITES TIME SERIES FILES FOR SURFACE ELEVATON,
C ** VELOCITY, CONCENTRATION, AND VOLUME SOURCES AT SPECIFIED
C ** (I,J) POINTS
C
USE GLOBAL
Found Structure @ 74835
SUBROUTINE TOXCHEM
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IF(ISTRAN(5).GE.1)THEN
DO NT=1,NTOX
C
C ** NOTES:
Found Structure @ 74878
REAL FUNCTION VALKH(HFFDG)
C
C CHANGE RECORD
C
USE GLOBAL
IF(HFFDG.LE.0.02)THEN
VALKH=HFFDG*HFFDG
RETURN
ENDIF
IF(HFFDG.GE.10.)THEN
Found Structure @ 78441
SUBROUTINE VARALLOC
USE GLOBAL
C
WRITE(*,'(A)')'ALLOCATING ARRAYS'
C
ALLOCATE(AAU(LCM))
ALLOCATE(AAV(LCM))
ALLOCATE(AB(LCM,KSM))
ALLOCATE(ABEFF(LCM,KSM))
ALLOCATE(ABLPF(LCM,KSM))
Found Structure @ 80517
SUBROUTINE VARINIT
C
USE GLOBAL
C
KPCM=1
MDVSM=1
MTVSM=1
NDDAM=1
NDQCLT=1
NDQCLT2=1
Found Structure @ 80605
SUBROUTINE VARZEROInt
! ***
! *** THIS SUBROUTINE ZERO'S ALL OF THE ARRAYS AFTER ALLOCATION
! ***
USE GLOBAL
!
WRITE(*,'(A)')'ZEROING Integer ARRAYS'
!
! *** INTEGER ARRAYS
Found Structure @ 81024
SUBROUTINE VARZEROReal
!C ***
!C *** THIS SUBROUTINE ZERO'S ALL OF THE ARRAYS AFTER ALLOCATION
!C ***
USE GLOBAL
!C
!C *** REAL ARRAYS
!C
WRITE(*,'(A)')'ZEROING REAL ARRAYS'
Found Structure @ 82684
SUBROUTINE VELPLTH
C
C CHANGE RECORD
C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L)
C TO MODIFIED THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/
C ** SUBROUTINE VELPLTH WRITES A HORIZONTAL INSTANTANEOUS VELOCITY
C ** VECTOR FILE
C
USE GLOBAL
INTEGER*4 VER
DIMENSION DBS(10)
Found Structure @ 83000
SUBROUTINE VELPLTV
C
C CHANGE RECORD
C ** SUBROUTINE VELPLTV WRITES A FIL FOR VERTICAL PLANE CONTOURING
C ** OF VELOCITY NORMAL TO AN ARBITARY SEQUENCE OF (I,J) POINTS AND
C ** AND VERTICAL PLANE TANGENTIAL-VERTICAL VELOCITY VECTORS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
C
USE GLOBAL
Found Structure @ 83207
SUBROUTINE VSFP
C
C CHANGE RECORD
C ** SUBROUTINES VSFP WRITES INSTANTANEOUS VERTICAL SCALAR FIELD
C ** PROFILES AT SPECIFIED HORIZONTAL SPACE-TIME LOCATIONS TO
C ** FILE VSFP.OUT
C
USE GLOBAL
REAL,ALLOCATABLE,DIMENSION(:)::DABVBT
Found Structure @ 83502
SUBROUTINE WASP4
C
C CHANGE RECORD
C ** SUBROUTINE WASPOUT WRITES OUTPUT FILES PROVIDING ADVECTIVE AND
C ** DIFFUSIVE TRANSPORT FIELDS FOR THE WASP4 WATER QUALITY MODEL
C
USE GLOBAL
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP
Found Structure @ 84116
SUBROUTINE WASP5
C
C CHANGE RECORD
C ** SUBROUTINE WASP5 WRITES OUTPUT FILES PROVIDING ADVECTIVE AND
C ** DIFFUSIVE TRANSPORT FIELDS FOR THE WASP5 WATER QUALITY MODEL
C
USE GLOBAL
CHARACTER*50 TITLEB,TITLEC
CHARACTER*12 HYDFIL
Found Structure @ 84920
SUBROUTINE WASP6
C
C CHANGE RECORD
C ==========
C REVISIONS:
C ==========
C M. MORTON 06/06/94: THIS VERSION WRITES DISPERSION TO THE WASPDH.OUT
C M. MORTON 06/07/94: WRITES HYDRODYNAMIC INFORMATION AND DISPERSION TO
C DATA GROUP B USE WASPB.MRM (DO NOT USE WASPB.OUT)
C DATA GROUP C USE WASPC.OUT
Found Structure @ 85977
SUBROUTINE WASP7
C
C CHANGE RECORD
C ==========
C REVISIONS:
C ==========
C M. MORTON 06/06/94: THIS VERSION WRITES DISPERSION TO THE WASPDH.OUT
C M. MORTON 06/07/94: WRITES HYDRODYNAMIC INFORMATION AND DISPERSION TO
C DATA GROUP B USE WASPB.MRM (DO NOT USE WASPB.OUT)
C DATA GROUP C USE WASPC.OUT
Found Structure @ 87102
C Paul
C please search for June 13 2008 to see code change
C this is EFDC_DS version of subroutine that does not have sal,temp linkage data
C written to HYD file
C Andy
C
C**********************************************************************C
C**********************************************************************C
Found Structure @ 88403
SUBROUTINE WAVEBL
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*9 FNWAVE
CHARACTER*1 CFNWAVE(0:9)
C
C ** INITIALIZE AND INPUT WAVE INFORMATION
C
IF(JSWAVE.EQ.1) GOTO 100
Found Structure @ 88688
SUBROUTINE WAVESXY
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** INPUT WAVE INFORMATION
C *** DSLLC BEGIN BLOCK
C
IF(JSWAVE.EQ.1) GOTO 100
Found Structure @ 89050
SUBROUTINE WELCOME
! *** CHANGE RECORD
! ***
! DATE MODIFIED BY
! 06/25/2006 Paul M. Craig
! Updated Code to Fortran 90
WRITE(6,1)
Found Structure @ 89091
MODULE WINDWAVE
USE GLOBAL
IMPLICIT NONE
INTEGER(4) ,PARAMETER::UFET=214 !FETCH.OUT
INTEGER(4) ,PARAMETER::UWIN=215 !LIJXY.OUT
INTEGER(4) ,PARAMETER::UTAU=216 !TAUW.OUT
REAL(RKD) ,PARAMETER::WHMI=1D-3 !MINIMUM WAVE HEIGHT
REAL(RKD) ::ROTAT !ANTICLOCKWISE ROTATION OF DOMAIN [0,360]
Found Structure @ 89208
SUBROUTINE WINDWAVECAL
!CALCULATING WAVE PARAMETERS FOR EVERY CELL
!BASED ON COMPUTED WIND PARAMETERS FROM WSER.INP AND SHELTERING
!INPUT:
!WNDVELE(L),WNDVELN(L),HP(L)
!OUTPUT:
!WVWHA(L),WVFRQL(L),WACCWE(L),WV%UDEL(L)
! WVWHA(L) - WAVE HEIGHT (M)
! WACCWE(L) - WAVE ANGLE (RADIANS)
! WVFRQL(L) - WAVE FREQENCY (SEC)
Found Structure @ 89290
FUNCTION FETZONE8(WDIR) RESULT(ZONE)
!DETERMINING FETCH ZONE AND FETCH MAIN ANGLE
!BASED ON THE GIVEN WIND DIRECTION WDIR
!WDIR : INTERPOLATED WIND DIRECTION FROM WSER.INP
!UNIT : [0,360]
!FORMATION: ANGLE BY (NORTH,WIND TO)IN CLOCKWISE DIRECTION
!ZONE 1: NORTH >337.5 OR <=22.5
!ZONE 2: NORTH-EAST >22.5 OR <=67.5
!ZONE 3: EAST >
!ZONE 4: SOUTH-EAST
Found Structure @ 89326
FUNCTION FETZONE(WDIR) RESULT(ZONE)
!DETERMINING FETCH ZONE AND FETCH MAIN ANGLE
!BASED ON THE GIVEN WIND DIRECTION WDIR
!WDIR : INTERPOLATED WIND DIRECTION FROM WSER.INP
!UNIT : [0,360]
!FORMATION: ANGLE BY (NORTH,WIND TO)IN CLOCKWISE DIRECTION
REAL(RKD) ,INTENT(IN )::WDIR ![0,360]
INTEGER(4)::ZONE
IF (WDIR>348.75 .OR. WDIR <= 11.25) THEN
Found Structure @ 89370
SUBROUTINE FETCH
!DETERMINING THE FETCHES OF ALL CELLS:
!OUTPUT: FWDIR(2:LA,1:NZONE) IN M
USE DRIFTER,ONLY:INSIDECELL
REAL(RKD)::AL(NZONE),RL,XM,YM,RL0
INTEGER(4)::I,J,L,NZ,IM,JM,LM,STATUS,MUL
OPEN(UFET,FILE='FETCH.OUT')
FWDIR = 0
AL = (180+90-FETANG-ROTAT)*PI/180._8 !ANTICLOCKWISE (X',WIND FR)
Found Structure @ 89412
SUBROUTINE WINDWAVEINIT
! *** INITIALIZES WAVE VARIABLES AND GENERATES FETCH.OUT
USE GLOBAL
INTEGER(4) ::L,K
ALLOCATE(WV%TWX(LA),WV%TWY(LA))
ALLOCATE(WV%UDEL(LA),WV%RLS(LA))
WV%TWX = 0
WV%TWY = 0
WV%UDEL = 0
Found Structure @ 89482
END MODULE
SUBROUTINE WQ3D(ISTL_,IS2TL_)
C
C CONTROL SUBROUTINE FOR WATER QUALITY MODEL
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C CHANGE RECORD
C
C Merged SNL and DS-INTL
Found Structure @ 89810
SUBROUTINE WQ3DINP
C
C READ WATER QUALITY SUBMODEL INPUT FILES
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*3 CWQHDR(NWQVM)
C PMC CHARACTER*11 HHMMSS
Found Structure @ 89994
SUBROUTINE WQSKE0
C**********************************************************************C
C
C Solve Kinetic Eq from K=KC (surface layer) to K=1 (bottom).
C Simplified version that only updates:
C IPARAM: 09 Dissolved Organic Phosphorus,
C 14 Ammonia Nitrogen
C 19 Dissolved Oxygen
C After computing new values, store WQVO+WQV into WQVO(L,K,NWQV) exce
Found Structure @ 90286
SUBROUTINE WQSKE1
C
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C
C CHANGE RECORD
C
C MAJOR REWRITE BY PAUL M. CRAIG JANUARY 12, 2006
C
USE GLOBAL
Found Structure @ 92153
SUBROUTINE COMPUTE_WC_ABOVE
! *** COMPUTE THE WATER COLUMN CONCENTRATIONS FOR TSS, POM AND CHLA
! *** THE
USE GLOBAL
REAL TSSS_ABOVE,WQCHLS_ABOVE,POMS_ABOVE
REAL K_ABOVE
K=KC
Found Structure @ 92208
SUBROUTINE WQSKE2
C
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C CHANGE RECORD
C
USE GLOBAL
C
CNS1=2.718
Found Structure @ 93800
SUBROUTINE WQSKE3
C
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C
C PMC - THIS IS THE SAME AS WQSKE2
C
USE GLOBAL
C
Found Structure @ 95391
SUBROUTINE WQSKE4
C
C**********************************************************************C
C
C SOLVE KINETIC EQ FROM K=KC (SURFACE LAYER) TO K=1 (BOTTOM).
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C
C**********************************************************************C
C
C ORGINALLY CODED BY K.-Y. PARK
Found Structure @ 97023
SUBROUTINE WQZERO
C
C M. MORTON 28 JUN 1998
C INITIALIZES THE WATER QUALITY AVERAGING SUMMATION ARRAYS:
C CHANGE RECORD
C
USE GLOBAL
C
DO LL=2,LA
DO K=1,KC
DO NW=1,NWQV
Found Structure @ 97077
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE WQZERO2
C
C**********************************************************************C
C
C M. MORTON 12 APR 1999
Found Structure @ 97135
SUBROUTINE WQZERO3
C
C M. MORTON 29 APR 1999
C INITIALIZES THE LIMITATION AND D.O. COMPONENT ANALYSIS ARRAYS:
C CHANGE RECORD
C
USE GLOBAL
DO LL=2,LA
DO K=1,KC
C
C ZERO THE DIURNAL DO VARIABLES:
Found Structure @ 97186
SUBROUTINE WQZERO4
C
C M. MORTON 02 JUN 1999
C INITIALIZES THE BENTHIC FLUX ARRAYS TO 0.0
C CHANGE RECORD
C
USE GLOBAL
DO LL=2,LA
C
C ZERO THE BENTHIC FLUX ARRAYS:
Found Structure @ 97211
SUBROUTINE WSMRST
C
C CHANGE RECORD
C WRITE SPATIAL DISTRIBUTIONS AT THE END OF SIMULATION TO UNIT ISMORST.
C
USE GLOBAL
C
C LOGICAL FEXIST
C WRITE ASCII RESTART FILE:
C
Found Structure @ 97252
SUBROUTINE WSMTS
C
C CHANGE RECORD
C WRITE TIME-SERIES OUTPUT
C
USE GLOBAL
OPEN(1,FILE='WQSDTS1.OUT',STATUS='UNKNOWN',POSITION='APPEND')
OPEN(2,FILE='WQSDTS2.OUT',STATUS='UNKNOWN',POSITION='APPEND')
IF(ISDYNSTP.EQ.0)THEN
TIMTMP=DT*FLOAT(N)+TCON*TBEGIN
Found Structure @ 97288
SUBROUTINE WSMTSBIN
C
C CHANGE RECORD
C WRITE SEDIMENT TIME-SERIES OUTPUT TO BINARY FILE.
C AVERAGES BENTHIC FLUX RATES OVER ISMTSDT TIME STEPS (E.G., DAILY AVG).
C
USE GLOBAL
IF(ISSDBIN .GT. 0)THEN
IF( MOD(ITNWQ,ISMTSDT) .EQ. 0 )THEN
NREC4 = NREC4+1
Found Structure @ 97329
SUBROUTINE WWQNC
C
C CHANGE RECORD
C WRITE INFORMATION OF NEGATIVE WQ STATE VARIABLES (UNIT IWQONC).
C
USE GLOBAL
CHARACTER*5 WQVN(NTSWQVM)
DATA WQVN/
& 'BC ','BD ','BG ','RPOC','LPOC','DOC ','RPOP','LPOP',
Found Structure @ 97357
SUBROUTINE WWQRST
C
C CHANGE RECORD
C WRITE SPATIAL DISTRIBUTIONS AT THE END OF SIMULATION TO UNIT IWQORST.
C
USE GLOBAL
C
C WRITE ASCII RESTART FILE:
C
OPEN(1,FILE='WQWCRST.OUT',STATUS='UNKNOWN')
Found Structure @ 97399
SUBROUTINE WWQTS
C
C ** SHEN'S MODIFICATION TO OUTPUT MACROALGAE
C CHANGE RECORD
C WRITE TIME-SERIES OUTPUT: WQCHLX=1/WQCHLX
C
USE GLOBAL
C
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WQVOUT
IF(.NOT.ALLOCATED(WQVOUT))THEN
Found Structure @ 97507
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE WWQTSBIN
C
C**********************************************************************C
C WRITE TIME-SERIES OUTPUT: WQCHLX=1/WQCHLX TO BINARY FILE
C**********************************************************************C
Found Structure @ 98230
FUNCTION ZBRENT(ISMERR)
C
C USING BRENT'S METHOD, FIND THE ROOT OF A FUNC SEDFLUX KNOWN TO LIE
C BETWEEN RMIN & RMAX WITHIN AN ACCURACY OF TOL (P. 253 IN NUMERICAL
C RECIPE).
C
EXTERNAL SEDFLUX
PARAMETER (IZMAX=100,EPS=3.0E-8,TOL=1.0E-5,
& RMIN=1.0E-4,RMAX=100.0)
ISMERR = 0
A = RMIN
Found Entry @ 15100
ENTRY SHORT_WAVE_RADIATION(WSPD,TD,TAIR,CLD,ATMPR,SRO,SRON)
******* Input Conversions
IF(TD.LT.1.1.AND.IRELH(NASER).EQ.1)THEN
! *** TD IS RELATIVE HUMIDITY. CONVERT TO DEW POINT
! *** Jensen et al. (1990) ASCE Manual No. 70 (see pages 176 & 177)
! *** Ambient vapor pressure in kPa
VaporP=TD* 0.611*EXP(17.27*TAIR/(TAIR+237.3))
! *** Compute dewpoint temperature (Tdew) in C
Found Entry @ 15167
ENTRY EQUILIBRIUM_TEMPERATURE(SRON,ET,CSHE)
******* British units
! *** SRON Should already be adjusted for Shading & Reflection
SRO_BR = SRON*W_M2_TO_BTU_FT2_DAY
******* Equilibrium temperature and heat exchange coefficient
ET = TDEW_F
TSTAR = (ET+TDEW_F)*0.5
_
Found Structure @ 55336
SUBROUTINE NEGDEP(QCHANUT,QCHANVT,ISTL_)
C
C CHANGE RECORD
C ADDED ALTERNATE SOR EQUATION SOLVER RELAX2T
C ** SUBROUTINE NEGDEP CHECK EXTERNAL SOLUTION FOR NEGATIVE DEPTHS
C
USE GLOBAL
DIMENSION QCHANUT(NCHANM),QCHANVT(NCHANM)
C
C ** CHECK FOR NEGATIVE DEPTHS
Found Structure @ 55510
SUBROUTINE OUT3D
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER *11 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN,
& CMPFN,SNDFN,TOXFN
REAL,ALLOCATABLE,DIMENSION(:,:)::AKL
REAL,ALLOCATABLE,DIMENSION(:,:)::AIJ
Found Structure @ 56886
SUBROUTINE OUTPUT1
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** PLOT SURFACE ELEVATION
C
DO L=2,LA
PAM(L)=P(L)*GI
Found Structure @ 57040
SUBROUTINE OUTPUT2
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** OUTPUT RESULTS OF RELAXATION SOLUTION
C
WRITE (7,40) RP
40 FORMAT (1H1,' RESULTS OF RELAX SOLUTION - RP=',F5.2,//)
Found Structure @ 57098
SUBROUTINE PPLOT (IPT)
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER BLANK,ASTER,LET1(51),LET2(51)
DIMENSION BNDU(51),BNDL(51)
CHARACTER*1,ALLOCATABLE,DIMENSION(:,:)::CHARY
DATA BLANK/' '/
DATA ASTER/'*'/
Found Structure @ 57188
SUBROUTINE QUIT
INTERFACE TO FUNCTION GETCH
& [C,ALIAS:'__getch']
& ()
CHARACTER GETCH*1
END
CHARACTER KEY*1
WRITE(*,'(''TAP SPACEBAR TO EXIT''\)')
KEY=GETCH()
RETURN
Found Structure @ 57200
SUBROUTINE RCAHQ
C
C CHANGE RECORD
C ** SUBROUTINE FOR INTERFACING RCA MODEL
C ** MODIFIED FROM WCA2A PROUDCTION VERSION
C ** WITH WITHDRAWL-RETURN FLOW OPTION DEACTIVATED BY CNWR
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 57945
SUBROUTINE RELAX2T
C
C CHANGE RECORD
C ADDED THIS SUBROUTINE RELAX2T
C ** SUBROUTINE RELAX SOLVES THE FINITE DIFFERENCE FORM
C ** OF A PSEUDO HEMHOLTZ EQUATION
C **
C ** CS(L)*P(LS)+CW(L)*P(L-1)
C ** +CC(L)*P(L)+CE(L)*P(L+1)
C **
Found Structure @ 58033
SUBROUTINE RESTIN1
C
C CHANGE RECORD
C ADDED CODE TO PROPERLY INITIAL RESTART INPUT FOR DRYING AND WETTING
C ** SUBROUTINE RESTIN1 READS A RESTART FILE
C
USE GLOBAL
REAL,ALLOCATABLE,DIMENSION(:)::TDUMMY
ALLOCATE(TDUMMY(KCM))
Found Structure @ 58696
SUBROUTINE RESTIN10
C
C CHANGE RECORD
C ** SUBROUTINE RESTINP READS A RESTART FILE GENERATED BY A
C ** PRE SEPTEMBER 8, 1992 VERSION OF EFDC.FOR
C
USE GLOBAL
PRINT *,'READING RESTIN10 FILE: RESTART.INP'
OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN')
Found Structure @ 58989
SUBROUTINE RESTIN2
C
C CHANGE RECORD
C ** SUBROUTINE RESTINP READS A RESTART FILE FOR (KC/2) LAYERS AND
C ** AND INITIALIZES FOR KC LAYERS
C
USE GLOBAL
PRINT *,'READING RESTIN2 FILE: RESTART.INP'
OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN')
Found Structure @ 59198
SUBROUTINE RESTMOD
C
C CHANGE RECORD
C ** SUBROUTINE RESTOUT WRITES A RESTART FILE
C
USE GLOBAL
DIMENSION LIJMOD(100)
OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN')
Found Structure @ 59304
SUBROUTINE RESTOUT(IRSTYP)
C
C CHANGE RECORD
C 11/14/2001 JOHN HAMRIC 11/14/2001 JOHN HAMRIC
C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY
C ** SUBROUTINE RESTOUT WRITES A RESTART FILE
C
USE GLOBAL
IF(IRSTYP.EQ.0)THEN
Found Structure @ 59792
SUBROUTINE ROUT3D
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER *12 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN,
& CMPFN,SNDFN,TOXFN
REAL,ALLOCATABLE,DIMENSION(:,:)::AIJ
Found Structure @ 61176
SUBROUTINE RSALPLTH(ICON,CONC)
C
C CHANGE RECORD
C ** SUBROUTINE RSALPLTH WRITES FILES FOR RESIDUAL SCALAR FIELD
C ** CONTOURING IN HORIZONTAL PLANES
C
USE GLOBAL
DIMENSION DBS(10)
CHARACTER*80 TITLE
DIMENSION CONC(LCM,KCM)
Found Structure @ 61489
SUBROUTINE RSALPLTV(ITMP)
C
C CHANGE RECORD
C ** SUBROUTINE RSALPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF RESIDUAL SALINITY AND VERTICAL DIFFUSIVITY ALONG AN ARBITARY
C ** SEQUENCE OF (I,J) POINTS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 61998
SUBROUTINE RSMICI(ISMTICI)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INSMICI).
C
USE GLOBAL
CHARACTER TITLE(3)*79,ICICONT*3
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XSMPOC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XSMPON
Found Structure @ 62075
SUBROUTINE RSMRST
C
C CHANGE RECORD
C READ ICS FROM RESTART FILE FROM INSMRST.
C
USE GLOBAL
LOGICAL FEXIST
C
C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE
C THE ASCII FILE INSTEAD.
Found Structure @ 62122
SUBROUTINE RSURFPLT
C
C CHANGE RECORD
C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE
C ** ELEVATION
C
USE GLOBAL
CHARACTER*80 TITLE
IF(JSRPPH.NE.1) GOTO 300
OPEN(10,FILE='RSURFCN.OUT',STATUS='UNKNOWN')
Found Structure @ 62165
SUBROUTINE RVELPLTH
C
C CHANGE RECORD
C ** SUBROUTINE RVELPLTH WRITES HORIZONTAL EULERIAN RESIDUAL, VECTOR
C ** POTENTIAL AND MEAN MASS TRANSPORT VELOCITY VECTOR FILES
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
DIMENSION DBS(10)
Found Structure @ 62266
SUBROUTINE RVELPLTV
C
C CHANGE RECORD
C ** SUBROUTINE VELPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF VELOCITY NORMAL TO AN ARBITARY SEQUENCE OF (I,J) POINTS AND
C ** AND VERTICAL PLANE TANGENTIAL-VERTICAL VELOCITY VECTORS
C
USE GLOBAL
CHARACTER*80 TITLE10,TITLE20,TITLE30
Found Structure @ 62827
SUBROUTINE RWQAGR(IWQTAGR)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR ALGAL
C GROWTH, RESP. & PREDATION RATES, AND BASE LIGHT EXTINCT. COEFF.
C (UNIT INWQAGR).
C
USE GLOBAL
CHARACTER TITLE(3)*79, AGRCONT*3
OPEN(1,FILE=AGRFN,STATUS='UNKNOWN')
Found Structure @ 62874
SUBROUTINE RWQATM
C
C CHANGE RECORD
C ** COMPUTES WET ATMOSPHERIC DEPOSITION USING CONSTANT CONCENTRATIONS
C ** FOR THE 22 STATE VARIABLES MULTIPLIED BY THE RAINFALL FLOW RATE !VB CHANGED 21 TO 22
C ** ENTERING EACH GRID CELL. COMPUTED LOADS ARE IN G/DAY.
C
USE GLOBAL
C
C CV2 = CONVERSION TO GET UNITS OF G/DAY
Found Structure @ 62917
SUBROUTINE RWQBEN2 (TIMTMP)
C
C M. MORTON 01/30/98: CHANGED CODE TO ALLOW FOR TEMPORALLY
C VARYING BENTHIC FLUXES IN THE BENFN FILE. PREVIOUS VERSION ONLY
C PROVIDED SPATIALLY VARYING FLUX (NO PROVISION FOR TIME VARYING).
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR BENTHIC
C FLUXES OF PO4D, NH4, NO3, SAD, COD, O2
C FORMAT OF BENFN FILE IS:
C TITLE 1
Found Structure @ 63038
SUBROUTINE RWQC1
C
C CHANGE RECORD
C READ IN FROM THE UNIT #8
C: I/O CONTROL VARIABLES
C: SPATIALLY AND TEMPORALLY CONSTANT REAL PARAMETERS
C
USE GLOBAL
C
IMPLICIT NONE
Found Structure @ 64872
SUBROUTINE RWQCSR
C
C CHANGE RECORD
C
USE GLOBAL
IMPLICIT NONE
CHARACTER*11 FNWQSR(40)
CHARACTER*2 SNUM
Found Structure @ 64950
SUBROUTINE RWQICI
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INWQICI).
C
USE GLOBAL
CHARACTER TITLE(3)*79, ICICONT*3
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XWQV
IF(.NOT.ALLOCATED(XWQV))THEN
ALLOCATE(XWQV(NWQVM))
Found Structure @ 65023
C ***
C *** READ IN TEMPORALLY VARYING POINT SOURCE INPUT (UNIT INWQPSL).
C *** INPUT UNITS (KG/D) EXCEPT: TAM(KMOL/D), FCB(MPN/D).
C *** COMPUTATIONAL UNITS, WQ CONSTITUENT LOADS ARE IN G/DAY,
C *** EXCEPT TAM IN (MOL/D) & FCB IN (MPN/D).
C
SUBROUTINE RWQPSL
C
C CHANGE RECORD
C
Found Structure @ 65237
SUBROUTINE RWQRST
C
C CHANGE RECORD
C READ ICS FROM RESTART FILE FROM INWQRST.
C
USE GLOBAL
LOGICAL FEXIST
C
C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE
C THE ASCII FILE INSTEAD.
Found Structure @ 65297
SUBROUTINE RWQSTL(IWQTSTL)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR SETTLING
C VELOCITIES OF ALGAE, RPOM, LPOM & PARTICULATE METAL (UNIT INWQSTL).
C ALSO SPATIALLY/TEMPORALLY VARYING REAERATION ADJUSTMENT FACTOR.
C
C
C *** WQWSC = Settling velocity for cyanobacteria (m/day)
C *** WQWSD = Settling velocity for algae diatoms (m/day)
Found Structure @ 65351
C
C READ IN TEMPORALLY VARYING PARAMETERS FOR DAILY SOLAR RADIATION (WQI0)
C AND FRACTIONAL DAYLENGTH (WQFD) (UNIT INWQSUN).
C
SUBROUTINE RWQSUN
C
C ** NEW VERSION BY J. M. HAMRICK 7 APRIL 1997
C CHANGE RECORD
C ** READS AND INTERPOLATES DAILY AVERAGE SOLAR RADIATION AND
C ** DAYLIGHT FRACTION
Found Structure @ 65429
SUBROUTINE BEDLOADJ
USE GLOBAL
IMPLICIT NONE
INTEGER::I,J,L,K
!PT: real values are written in DOUBLE PRECISION 7/16/08.
DOUBLE PRECISION,DIMENSION(LCM)::VELMAG
!
! University of California, Santa Barbara
! Craig Jones and Wilbert Lick
!
Found Structure @ 65544
!**********************************************************************!
SUBROUTINE SEDZLJ_MAIN
USE GLOBAL
IMPLICIT NONE
DOUBLE PRECISION,DIMENSION(LCM)::WVEL,CLEFT,CRIGHT,GRADSED,SEDAVG,CRNUM,CRAIG
INTEGER::L,K,NS
DOUBLE PRECISION::AA11,AA12,AA21,AA22,BB11,BB22,DETI
! PT: real values are written in DOUBLE PRECISION. 7/16/08
!**********************************************************************!
!
! ** SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING,
Found Structure @ 65993
SUBROUTINE MORPHJ
! REVISION DATE : May 24, 2006
! Craig Jones and Scott James
!***************************************************************
USE GLOBAL
IMPLICIT NONE
!REAL::TMPVAL
!INTEGER::ITMP,K,L,LL,NS,NT
!REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED
DOUBLE PRECISION::TMPVAL
Found Structure @ 66068
SUBROUTINE SEDIC
USE GLOBAL
IMPLICIT NONE
INTEGER::CORE,I,INCORE,J,L,LL,M,K,NS,VAR_BED,NSCICM,FDIR,NWV
INTEGER::IWV,JWV,NSKIP
CHARACTER(LEN=80)::STR_LINE
!PT- real values are written in DOUBLE PRECISION. 7/16/08
DOUBLE PRECISION::BLKTMP,STWVHTMP,STWVTTMP,STWVDTMP
DOUBLE PRECISION,DIMENSION(10)::PTEMP
DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::BDEN !(INCORE,KB)
DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::TAUTEMP !(KB)
Found Structure @ 66410
SUBROUTINE SEDZLJ(L)
USE GLOBAL
IMPLICIT NONE
INTEGER::KK,LL,K,L
INTEGER::NSC0,NSC1,NTAU0,NTAU1
DOUBLE PRECISION::WDTDZ,SURFACE
DOUBLE PRECISION::SN00
DOUBLE PRECISION::SN01
DOUBLE PRECISION::SN10
DOUBLE PRECISION::SN11
Found Structure @ 66784
SUBROUTINE SEDZLJ_SHEAR
USE GLOBAL
IMPLICIT NONE
INTEGER::L
INTEGER::M1,M2
INTEGER::FZONE
!PT: All real values are explicitly written in DOUBLE PRECISION 7/16/08.
DOUBLE PRECISION::TEMP,MMW,SIGMAWV,JJW
Found Structure @ 67016
SUBROUTINE SALPLTH (ICON,CONC)
C
C CHANGE RECORD
C ** SUBROUTINE SALPLTH WRITES FILES FOR INSTANTANEOUS SCALAR FIELD
C ** CONTOURING IN HORIZONTAL PLANES
C
USE GLOBAL
DIMENSION DBS(10)
CHARACTER*80 TITLE
DIMENSION CONC(LCM,KCM)
Found Structure @ 67584
SUBROUTINE SALPLTV(ITMP)
C
C CHANGE RECORD
C ** SUBROUTINE SALPLTV WRITES A FILE FOR VERTICAL PLANE CONTOURING
C ** OF SALINITY, DYE CONCENTRATION, AND SEDIMENT CONCENTRATION
C ** ALONG AN ARBITARY SEQUENCE OF (I,J) POINTS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
USE GLOBAL
Found Structure @ 68272
SUBROUTINE SALTSMTH
C
C CHANGE RECORD
C
USE GLOBAL
IF(NSBMAX.GT.10) GOTO 1001
C
C ELSE
C GOTO 1001
C
Found Structure @ 68362
SUBROUTINE SCANASER
USE GLOBAL
CHARACTER*120 LIN
WRITE(*,'(A)')'SCANNING INPUT FILE: ASER.INP'
OPEN(1,FILE='ASER.INP',STATUS='OLD')
DO N=1,NASER
10 READ(1,*,ERR=10,END=40)M,R,R,I,R,R,R,R
READ(1,*,ERR=20,END=40)I,R,R,R,R,R,R,R,R,R
NDASER=MAX(NDASER,M)
Found Structure @ 68404
SUBROUTINE SCANDSER(NCSER3)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: DSER.INP'
OPEN(1,FILE='DSER.INP',STATUS='OLD')
DO NS=1,NCSER3
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO I=1,M
Found Structure @ 68434
SUBROUTINE SCANEFDC(NCSER1,NCSER2,NCSER3,NCSER4)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: EFDC.INP'
OPEN(1,FILE='EFDC.INP',STATUS='OLD')
CALL SEEK('C4')
READ(1,*,ERR=10) ISLTMT,ISSSMMT,ISLTMTS,ISIA,RPIA,RSQMIA,
& ITRMIA,ISAVEC
Found Structure @ 68643
SUBROUTINE SCANGWSR
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: GWSER.INP'
OPEN(1,FILE='GWSER.INP',STATUS='OLD')
10 READ(1,*,ERR=10,END=40)NGWSER
NGWSERM=MAX(1,NGWSER)
DO NS=1,NGWSER
READ(1,*,ERR=20,END=40)M,R,R,R,R
NDGWSER=MAX(NDGWSER,M)
DO I=1,M
Found Structure @ 68668
SUBROUTINE SCANMODC
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: MODCHAN.INP'
OPEN(1,FILE='MODCHAN.INP',STATUS='OLD')
10 READ(1,*,ERR=10,END=40)M,I,I
NCHANM=MAX(1,M)
READ(1,*,ERR=20,END=40)I,I,R
CLOSE(1)
RETURN
20 WRITE(*,30)
Found Structure @ 68687
SUBROUTINE SCANPSER
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: PSER.INP'
OPEN(1,FILE='PSER.INP',STATUS='OLD')
DO NS=1,NPSER
10 READ(1,*,ERR=10,END=40)M,R,R,R,R
NDPSER=MAX(NDPSER,M)
DO I=1,M
READ(1,*,ERR=20,END=40)R,R
ENDDO
Found Structure @ 68711
SUBROUTINE SCANQCTL
USE GLOBAL
CHARACTER*80 SKIP
CHARACTER*10 INFILE
WRITE(*,'(A)')'SCANNING INPUT FILE: QCTL.INP'
INFILE='QCTL.INP'
OPEN(1,FILE='QCTL.INP',STATUS='UNKNOWN')
! *** FIND THE MAXIMUM NUMBER OF TABLE DATA POINTS
Found Structure @ 68752
SUBROUTINE SCANQSER
USE GLOBAL
INTEGER*4 NS, I, J, M
WRITE(*,'(A)')'SCANNING INPUT FILE: QSER.INP'
OPEN(1,FILE='QSER.INP',STATUS='OLD')
DO NS=1,NQSER
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R,J
NDQSER=MAX(NDQSER,M)
IF(I.EQ.1)THEN
Found Structure @ 68785
C *****************************************************************************
SUBROUTINE SCANQWSER
USE GLOBAL
INTEGER*4 NTMP, I, J, M, NV
NTMP=4+NSED+NSND+NTOX
! *** Handle Water Quality variables, if needed
IF(ISTRAN(8).GT.0)THEN
WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP (PRELIM)'
Found Structure @ 68836
SUBROUTINE SCANSEDZLJ
!
! REVISION DATE : May 24, 2006
! Craig Jones and Scott James
!***************************************************************
USE GLOBAL
IMPLICIT NONE
INTEGER::IDUMMY,ERROR
!
WRITE(*,'(A)')'SCANNING INPUT FILE: BED.SDF'
OPEN(1,FILE='BED.SDF',STATUS='OLD')
Found Structure @ 68874
SUBROUTINE SCANSFSR(NCSER4)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: SFSER.INP'
OPEN(1,FILE='SFSER.INP',STATUS='OLD')
DO NS=1,NCSER4
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68904
SUBROUTINE SCANSSER(NCSER1)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: SSER.INP'
OPEN(1,FILE='SSER.INP',STATUS='OLD')
DO NS=1,NCSER1
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68934
SUBROUTINE SCANTSER(NCSER2)
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: TSER.INP'
OPEN(1,FILE='TSER.INP',STATUS='OLD')
DO NS=1,NCSER2
10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R
NDCSER=MAX(NDCSER,M)
IF(I.EQ.1)THEN
READ(1,*,ERR=20,END=40)(R,K=1,KC)
DO J=1,M
Found Structure @ 68964
SUBROUTINE SCANWQ
! *** Merged SNL & DS-INTL Codes
USE GLOBAL
CHARACTER*10 INFILE
CHARACTER*2 SNUM
CHARACTER*120 LINE
CHARACTER*11 FNWQSR(40)
Found Structure @ 69103
SUBROUTINE SCANWSER
USE GLOBAL
WRITE(*,'(A)')'SCANNING INPUT FILE: WSER.INP'
OPEN(1,FILE='WSER.INP',STATUS='OLD')
DO NS=1,NWSER
10 READ(1,*,ERR=10,END=40)M,R,R,R,I
NDWSER=MAX(NDWSER,M)
DO I=1,M
READ(1,*,ERR=20,END=40)R,R,R
ENDDO
ENDDO
Found Structure @ 69125
SUBROUTINE SCNTXSED
USE GLOBAL
CHARACTER*80 SKIP
CHARACTER*10 INFILE
! *** NOW FIND MAX FOR TOXICS AND SEDIMENTS
DO N=1,3
NCSERNC=0
IF(N.EQ.1)THEN
Found Structure @ 69208
FUNCTION SEDFLUX(SMSOD1)
C
C SOLVE MASS-BALANCE EQ'S FOR NH4, NO3 & H2S/CH4 AND THEIR FLUXES.
C
USE GLOBAL
RSMSS = SMSOD1 / (SMO20+ 1.E-18)
C
C NH4
C
RRNH4 = SK1NH4SM/(RSMSS+ 1.E-18)
A11NH4 = RSMSS*SMFD1NH4 + A1NH4SM + RRNH4
Found Structure @ 69272
SUBROUTINE SEEK(TAG)
C
CHARACTER TAG*(*)
CHARACTER*80 TEXT
C
L=LEN(TAG)
DO I=1,L
J=ICHAR(TAG(I:I))
IF(97.LE.J.AND.J.LE.122)THEN
TAG(I:I)=CHAR(J-32)
Found Structure @ 69311
SUBROUTINE SETBCS
C
C CHANGE RECORD
C MODIFIED BOUNDARY CONDITION FLAGS FOR TYPE 2 OPEN BOUNDARIES
C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L)
C TO MODIFIED CALCULATION OF CELL CENTER BED STRESS (STORED AS QQ(L,0))
C AND THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/SINKS
C ** SUBROUTINE SETBCS SETS BOUNDARY CONDITION SWITCHES
C
USE GLOBAL
Found Structure @ 70176
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE SETFPOCB(ITYPE)
C
C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION 1.0a
C
C ** LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
Found Structure @ 70446
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE SETOBC2T(DE_T,D_LTD2,DE_TI)
C
C TT Version (Only used with TT versions of CALPUV)
C
C CHANGE RECORD
C
Found Structure @ 70596
SUBROUTINE SETOPENBC(DE_T,D_LTD2,DE_TI,HUT,HVT)
C
C CHANGE RECORD
C ** SUBROUTINE SETOBC SETS OPEN BOUNDARY CONDITIONS FOR
C CALPUV2T & CALPUV2C AND CALPUV9 & CALPUV9C
C
C *** MODIFIED BY PAUL M. CRAIG TO ADDRESS MOVING CALL IN CALPUV2#
C
USE GLOBAL
C
Found Structure @ 70760
SUBROUTINE SETOPENBC2
C
C CHANGE RECORD
C ** SUBROUTINE SETOBC SETS OPEN BOUNDARY CONDITIONS FOR
C CALPUV2T & CALPUV2C AND CALPUV9 & CALPUV9C
C
C *** MODIFIED BY PAUL M. CRAIG
C
USE GLOBAL
C
Found Structure @ 70806
SUBROUTINE SETSHLD(TSC,THETA,D,SSG,DSR,USC)
C
C CHANGE RECORD
C
C
C ** NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C ** USING VAN RIJN'S EQUATIONS
C
VISC=1.E-6
GP=(SSG-1.)*9.82
TMP=GP/(VISC*VISC)
Found Structure @ 70841
FUNCTION SETSTVEL(D,SSG)
C
C CHANGE RECORD
C
C
C ** NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C ** USING VAN RIJN'S EQUATIONS
C
VISC=1.E-6
GP=(SSG-1.)*9.82
Found Structure @ 70871
SUBROUTINE SHOWVAL
! *** REWRITTEN BY PAUL M. CRAIG ON DEC 2006
! ***
! *** 2010_06 CHANGED THE NSHTYPE TO CORRESPOND TO PARAMETER LIST
USE GLOBAL
CHARACTER BLANK,ASTER,CSURF(32),CSALS(20),CSALB(20)
CHARACTER UNITS*3, PARM*3, CSUB*1
SAVE INFODT, JSHPRT, UNITS, SCALE, PARM
Found Structure @ 71123
SUBROUTINE SKIPCOMM(IUNIT, CC)
C
C CHANGE RECORD
C SKIPS OVER COMMENT LINES IN INPUT FILES
C
CHARACTER CC*1, LINE*120
100 READ(IUNIT, 8, END=999) LINE
WRITE(2,9)LINE
IF(LINE(1:1) .EQ. CC) GOTO 100
IF(LINE(1:1) .EQ. 'C') GOTO 100
IF(LINE(1:1) .EQ. 'c') GOTO 100
Found Structure @ 71139
SUBROUTINE SMINIT
C
C CHANGE RECORD
C
USE GLOBAL
SMTSNAME(1) = 'SOM'
SMTSNAME(2) = 'SIM'
SMTSNAME(3) = 'SBF'
DO L=2,LA
SMHYST(L)=.FALSE.
Found Structure @ 71153
SUBROUTINE SMMBE
C
C CHANGE RECORD
C CONTROL SUBROUTINE FOR SEDIMENT COMPONENT OF WATER QUALITY MODEL
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C AND BFSADSUM ARRAYS TO KEEP TRACK OF BENTHIC FLUXES AT ALL CELLS
C FOR LATER STORAGE IN BINARY FILE (WQSDTS.BIN).
C
USE GLOBAL
Found Structure @ 71497
SUBROUTINE SMRIN1()
C
C CHANGE RECORD
C
USE GLOBAL
PARAMETER (SMCW2=2.739726E-5) ! *** cm/y to m/day
CHARACTER TITLE(3)*79, CCMRM*1
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SMKPOC
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SMKPON
Found Structure @ 72088
SUBROUTINE SOLVSMBE(SMV1,SMV2,SMA11,SMA22,SMA1,SMA2,SMB11,SMB22)
C
C SOLVE 2X2 MATRIX
C CHANGE RECORD
C
SMA12 = -SMA2
SMA21 = -SMA1
SMDET = SMA11*SMA22 - SMA12*SMA21
IF(SMDET.EQ.0.0)THEN
PRINT*, 'SINGULAR MATRIX: A11, A12, A21, A22, B11, B22'
PRINT*, SMA11,SMA12,SMA21,SMA22,SMB11,SMB22
Found Structure @ 72106
SUBROUTINE SSEDTOX(ISTLX,IS2TLX,CORDTX)
C
C CHANGE RECORD
C CHANGED ADD AND REMOVE BED LAYER ALGORITHM - SEE SECTIONS UNDER
C IBMECH=0,1, AND GE 2
C CHANGED ADD AND REMOVE BED LAYER ALGORITHM - SEE SECTIONS UNDER
C IBMECH=0,1, AND GE 2
C MODIFIED NONCOHESIVE RESUSPENSION FORMULATION TO BE CONSISTENT
C WITH ADD AND REMOVE BED LAYER MODIFICATION
C ADDED NONCOHESIVE BEDLOAD-SUSPENDED LOAD DISTRIBUTION FACTOR
Found Structure @ 73231
SUBROUTINE SUBCHAN(QCHANUT,QCHANVT,IACTIVE,RLAMN,RLAMO,DE_T,
& IACTALL)
C
C CHANGE RECORD
C ** SUBROUTINE SUBCHAN CALCULATES SUBGRID CHANNEL INTERACTIONS AND IS
C ** CALLED FROM CALPUV2TC
C
USE GLOBAL
DIMENSION IACTIVE(NCHANM),QCHANUT(NCHANM),QCHANVT(NCHANM)
C
Found Structure @ 73368
SUBROUTINE SURFPLT
C
C CHANGE RECORD
C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE
C ** ELEVATION
C
USE GLOBAL
CHARACTER*80 TITLE
C
C *** EE BEGIN BLOCK
Found Structure @ 73478
SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
C
C ** FROM NUMERICAL RECIPES
C CHANGE RECORD
C
DIMENSION U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP)
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMP
IF(.NOT.ALLOCATED(TMP))ALLOCATE(TMP(N))
C
DO 12 J=1,N
Found Structure @ 73508
SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
C
C ** FROM NUMERICAL RECIPES
C CHANGE RECORD
C
DIMENSION A(MP,NP),W(NP),V(NP,NP)
REAL,ALLOCATABLE,DIMENSION(:)::RV1
ALLOCATE(RV1(N))
G=0.0
SCALE=0.0
Found Structure @ 73749
SUBROUTINE TECPLOT
!
! Tecplot customized output
! Calculate shear stress here even for non-sediment cases
!
! CALL SEDZLJ_SHEAR
!
! REVISION DATE: May 24, 2006
! Craig Jones and Scott James
Found Structure @ 73888
SUBROUTINE TIMELOG(N,TIMEDAY)
CHARACTER*8 MRMDATE,MRMTIME*10
C
C WRITE OUT MODEL TIME STEP AND SUN/PC SYSTEM CLOCK TIME TO TIME.LOG FIL
C
! *** WRITE OUT MODEL TIME STEP AND SYSTEM CLOCK TIME TO TIME.LOG
CALL DATE_AND_TIME(MRMDATE,MRMTIME)
WRITE(9,100)N,TIMEDAY,MRMDATE,MRMTIME
100 FORMAT(' ','N =',I10,5X,'TIMEDAY = ',F12.4,5X,'DATE = ',A8,
& 5X,'TIME = ',A10)
RETURN
Found Structure @ 73900
SUBROUTINE TMSR
C
C CHANGE RECORD
C CHANGED TOX BED OUTPUT
C ** SUBROUTINE TMSR WRITES TIME SERIES FILES FOR SURFACE ELEVATON,
C ** VELOCITY, CONCENTRATION, AND VOLUME SOURCES AT SPECIFIED
C ** (I,J) POINTS
C
USE GLOBAL
Found Structure @ 74835
SUBROUTINE TOXCHEM
C
C CHANGE RECORD
C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
USE GLOBAL
IF(ISTRAN(5).GE.1)THEN
DO NT=1,NTOX
C
C ** NOTES:
Found Structure @ 74878
REAL FUNCTION VALKH(HFFDG)
C
C CHANGE RECORD
C
USE GLOBAL
IF(HFFDG.LE.0.02)THEN
VALKH=HFFDG*HFFDG
RETURN
ENDIF
IF(HFFDG.GE.10.)THEN
Found Structure @ 78441
SUBROUTINE VARALLOC
USE GLOBAL
C
WRITE(*,'(A)')'ALLOCATING ARRAYS'
C
ALLOCATE(AAU(LCM))
ALLOCATE(AAV(LCM))
ALLOCATE(AB(LCM,KSM))
ALLOCATE(ABEFF(LCM,KSM))
ALLOCATE(ABLPF(LCM,KSM))
Found Structure @ 80517
SUBROUTINE VARINIT
C
USE GLOBAL
C
KPCM=1
MDVSM=1
MTVSM=1
NDDAM=1
NDQCLT=1
NDQCLT2=1
Found Structure @ 80605
SUBROUTINE VARZEROInt
! ***
! *** THIS SUBROUTINE ZERO'S ALL OF THE ARRAYS AFTER ALLOCATION
! ***
USE GLOBAL
!
WRITE(*,'(A)')'ZEROING Integer ARRAYS'
!
! *** INTEGER ARRAYS
Found Structure @ 81024
SUBROUTINE VARZEROReal
!C ***
!C *** THIS SUBROUTINE ZERO'S ALL OF THE ARRAYS AFTER ALLOCATION
!C ***
USE GLOBAL
!C
!C *** REAL ARRAYS
!C
WRITE(*,'(A)')'ZEROING REAL ARRAYS'
Found Structure @ 82684
SUBROUTINE VELPLTH
C
C CHANGE RECORD
C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L)
C TO MODIFIED THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/
C ** SUBROUTINE VELPLTH WRITES A HORIZONTAL INSTANTANEOUS VELOCITY
C ** VECTOR FILE
C
USE GLOBAL
INTEGER*4 VER
DIMENSION DBS(10)
Found Structure @ 83000
SUBROUTINE VELPLTV
C
C CHANGE RECORD
C ** SUBROUTINE VELPLTV WRITES A FIL FOR VERTICAL PLANE CONTOURING
C ** OF VELOCITY NORMAL TO AN ARBITARY SEQUENCE OF (I,J) POINTS AND
C ** AND VERTICAL PLANE TANGENTIAL-VERTICAL VELOCITY VECTORS
C
C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP?
C
USE GLOBAL
Found Structure @ 83207
SUBROUTINE VSFP
C
C CHANGE RECORD
C ** SUBROUTINES VSFP WRITES INSTANTANEOUS VERTICAL SCALAR FIELD
C ** PROFILES AT SPECIFIED HORIZONTAL SPACE-TIME LOCATIONS TO
C ** FILE VSFP.OUT
C
USE GLOBAL
REAL,ALLOCATABLE,DIMENSION(:)::DABVBT
Found Structure @ 83502
SUBROUTINE WASP4
C
C CHANGE RECORD
C ** SUBROUTINE WASPOUT WRITES OUTPUT FILES PROVIDING ADVECTIVE AND
C ** DIFFUSIVE TRANSPORT FIELDS FOR THE WASP4 WATER QUALITY MODEL
C
USE GLOBAL
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP
Found Structure @ 84116
SUBROUTINE WASP5
C
C CHANGE RECORD
C ** SUBROUTINE WASP5 WRITES OUTPUT FILES PROVIDING ADVECTIVE AND
C ** DIFFUSIVE TRANSPORT FIELDS FOR THE WASP5 WATER QUALITY MODEL
C
USE GLOBAL
CHARACTER*50 TITLEB,TITLEC
CHARACTER*12 HYDFIL
Found Structure @ 84920
SUBROUTINE WASP6
C
C CHANGE RECORD
C ==========
C REVISIONS:
C ==========
C M. MORTON 06/06/94: THIS VERSION WRITES DISPERSION TO THE WASPDH.OUT
C M. MORTON 06/07/94: WRITES HYDRODYNAMIC INFORMATION AND DISPERSION TO
C DATA GROUP B USE WASPB.MRM (DO NOT USE WASPB.OUT)
C DATA GROUP C USE WASPC.OUT
Found Structure @ 85977
SUBROUTINE WASP7
C
C CHANGE RECORD
C ==========
C REVISIONS:
C ==========
C M. MORTON 06/06/94: THIS VERSION WRITES DISPERSION TO THE WASPDH.OUT
C M. MORTON 06/07/94: WRITES HYDRODYNAMIC INFORMATION AND DISPERSION TO
C DATA GROUP B USE WASPB.MRM (DO NOT USE WASPB.OUT)
C DATA GROUP C USE WASPC.OUT
Found Structure @ 87102
C Paul
C please search for June 13 2008 to see code change
C this is EFDC_DS version of subroutine that does not have sal,temp linkage data
C written to HYD file
C Andy
C
C**********************************************************************C
C**********************************************************************C
Found Structure @ 88403
SUBROUTINE WAVEBL
C
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*9 FNWAVE
CHARACTER*1 CFNWAVE(0:9)
C
C ** INITIALIZE AND INPUT WAVE INFORMATION
C
IF(JSWAVE.EQ.1) GOTO 100
Found Structure @ 88688
SUBROUTINE WAVESXY
C
C CHANGE RECORD
C
USE GLOBAL
C
C ** INPUT WAVE INFORMATION
C *** DSLLC BEGIN BLOCK
C
IF(JSWAVE.EQ.1) GOTO 100
Found Structure @ 89050
SUBROUTINE WELCOME
! *** CHANGE RECORD
! ***
! DATE MODIFIED BY
! 06/25/2006 Paul M. Craig
! Updated Code to Fortran 90
WRITE(6,1)
Found Structure @ 89091
MODULE WINDWAVE
USE GLOBAL
IMPLICIT NONE
INTEGER(4) ,PARAMETER::UFET=214 !FETCH.OUT
INTEGER(4) ,PARAMETER::UWIN=215 !LIJXY.OUT
INTEGER(4) ,PARAMETER::UTAU=216 !TAUW.OUT
REAL(RKD) ,PARAMETER::WHMI=1D-3 !MINIMUM WAVE HEIGHT
REAL(RKD) ::ROTAT !ANTICLOCKWISE ROTATION OF DOMAIN [0,360]
Found Structure @ 89208
SUBROUTINE WINDWAVECAL
!CALCULATING WAVE PARAMETERS FOR EVERY CELL
!BASED ON COMPUTED WIND PARAMETERS FROM WSER.INP AND SHELTERING
!INPUT:
!WNDVELE(L),WNDVELN(L),HP(L)
!OUTPUT:
!WVWHA(L),WVFRQL(L),WACCWE(L),WV%UDEL(L)
! WVWHA(L) - WAVE HEIGHT (M)
! WACCWE(L) - WAVE ANGLE (RADIANS)
! WVFRQL(L) - WAVE FREQENCY (SEC)
Found Structure @ 89290
FUNCTION FETZONE8(WDIR) RESULT(ZONE)
!DETERMINING FETCH ZONE AND FETCH MAIN ANGLE
!BASED ON THE GIVEN WIND DIRECTION WDIR
!WDIR : INTERPOLATED WIND DIRECTION FROM WSER.INP
!UNIT : [0,360]
!FORMATION: ANGLE BY (NORTH,WIND TO)IN CLOCKWISE DIRECTION
!ZONE 1: NORTH >337.5 OR <=22.5
!ZONE 2: NORTH-EAST >22.5 OR <=67.5
!ZONE 3: EAST >
!ZONE 4: SOUTH-EAST
Found Structure @ 89326
FUNCTION FETZONE(WDIR) RESULT(ZONE)
!DETERMINING FETCH ZONE AND FETCH MAIN ANGLE
!BASED ON THE GIVEN WIND DIRECTION WDIR
!WDIR : INTERPOLATED WIND DIRECTION FROM WSER.INP
!UNIT : [0,360]
!FORMATION: ANGLE BY (NORTH,WIND TO)IN CLOCKWISE DIRECTION
REAL(RKD) ,INTENT(IN )::WDIR ![0,360]
INTEGER(4)::ZONE
IF (WDIR>348.75 .OR. WDIR <= 11.25) THEN
Found Structure @ 89370
SUBROUTINE FETCH
!DETERMINING THE FETCHES OF ALL CELLS:
!OUTPUT: FWDIR(2:LA,1:NZONE) IN M
USE DRIFTER,ONLY:INSIDECELL
REAL(RKD)::AL(NZONE),RL,XM,YM,RL0
INTEGER(4)::I,J,L,NZ,IM,JM,LM,STATUS,MUL
OPEN(UFET,FILE='FETCH.OUT')
FWDIR = 0
AL = (180+90-FETANG-ROTAT)*PI/180._8 !ANTICLOCKWISE (X',WIND FR)
Found Structure @ 89412
SUBROUTINE WINDWAVEINIT
! *** INITIALIZES WAVE VARIABLES AND GENERATES FETCH.OUT
USE GLOBAL
INTEGER(4) ::L,K
ALLOCATE(WV%TWX(LA),WV%TWY(LA))
ALLOCATE(WV%UDEL(LA),WV%RLS(LA))
WV%TWX = 0
WV%TWY = 0
WV%UDEL = 0
Found Structure @ 89482
END MODULE
SUBROUTINE WQ3D(ISTL_,IS2TL_)
C
C CONTROL SUBROUTINE FOR WATER QUALITY MODEL
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C CHANGE RECORD
C
C Merged SNL and DS-INTL
Found Structure @ 89810
SUBROUTINE WQ3DINP
C
C READ WATER QUALITY SUBMODEL INPUT FILES
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C CHANGE RECORD
C
USE GLOBAL
CHARACTER*3 CWQHDR(NWQVM)
C PMC CHARACTER*11 HHMMSS
Found Structure @ 89994
SUBROUTINE WQSKE0
C**********************************************************************C
C
C Solve Kinetic Eq from K=KC (surface layer) to K=1 (bottom).
C Simplified version that only updates:
C IPARAM: 09 Dissolved Organic Phosphorus,
C 14 Ammonia Nitrogen
C 19 Dissolved Oxygen
C After computing new values, store WQVO+WQV into WQVO(L,K,NWQV) exce
Found Structure @ 90286
SUBROUTINE WQSKE1
C
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C
C CHANGE RECORD
C
C MAJOR REWRITE BY PAUL M. CRAIG JANUARY 12, 2006
C
USE GLOBAL
Found Structure @ 92153
SUBROUTINE COMPUTE_WC_ABOVE
! *** COMPUTE THE WATER COLUMN CONCENTRATIONS FOR TSS, POM AND CHLA
! *** THE
USE GLOBAL
REAL TSSS_ABOVE,WQCHLS_ABOVE,POMS_ABOVE
REAL K_ABOVE
K=KC
Found Structure @ 92208
SUBROUTINE WQSKE2
C
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C CHANGE RECORD
C
USE GLOBAL
C
CNS1=2.718
Found Structure @ 93800
SUBROUTINE WQSKE3
C
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C ORGINALLY CODED BY K.-Y. PARK
C OPTIMIZED AND MODIFIED BY J.M. HAMRICK
C
C PMC - THIS IS THE SAME AS WQSKE2
C
USE GLOBAL
C
Found Structure @ 95391
SUBROUTINE WQSKE4
C
C**********************************************************************C
C
C SOLVE KINETIC EQ FROM K=KC (SURFACE LAYER) TO K=1 (BOTTOM).
C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT
C: NWQV=15,19,21.
C
C**********************************************************************C
C
C ORGINALLY CODED BY K.-Y. PARK
Found Structure @ 97023
SUBROUTINE WQZERO
C
C M. MORTON 28 JUN 1998
C INITIALIZES THE WATER QUALITY AVERAGING SUMMATION ARRAYS:
C CHANGE RECORD
C
USE GLOBAL
C
DO LL=2,LA
DO K=1,KC
DO NW=1,NWQV
Found Structure @ 97077
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE WQZERO2
C
C**********************************************************************C
C
C M. MORTON 12 APR 1999
Found Structure @ 97135
SUBROUTINE WQZERO3
C
C M. MORTON 29 APR 1999
C INITIALIZES THE LIMITATION AND D.O. COMPONENT ANALYSIS ARRAYS:
C CHANGE RECORD
C
USE GLOBAL
DO LL=2,LA
DO K=1,KC
C
C ZERO THE DIURNAL DO VARIABLES:
Found Structure @ 97186
SUBROUTINE WQZERO4
C
C M. MORTON 02 JUN 1999
C INITIALIZES THE BENTHIC FLUX ARRAYS TO 0.0
C CHANGE RECORD
C
USE GLOBAL
DO LL=2,LA
C
C ZERO THE BENTHIC FLUX ARRAYS:
Found Structure @ 97211
SUBROUTINE WSMRST
C
C CHANGE RECORD
C WRITE SPATIAL DISTRIBUTIONS AT THE END OF SIMULATION TO UNIT ISMORST.
C
USE GLOBAL
C
C LOGICAL FEXIST
C WRITE ASCII RESTART FILE:
C
Found Structure @ 97252
SUBROUTINE WSMTS
C
C CHANGE RECORD
C WRITE TIME-SERIES OUTPUT
C
USE GLOBAL
OPEN(1,FILE='WQSDTS1.OUT',STATUS='UNKNOWN',POSITION='APPEND')
OPEN(2,FILE='WQSDTS2.OUT',STATUS='UNKNOWN',POSITION='APPEND')
IF(ISDYNSTP.EQ.0)THEN
TIMTMP=DT*FLOAT(N)+TCON*TBEGIN
Found Structure @ 97288
SUBROUTINE WSMTSBIN
C
C CHANGE RECORD
C WRITE SEDIMENT TIME-SERIES OUTPUT TO BINARY FILE.
C AVERAGES BENTHIC FLUX RATES OVER ISMTSDT TIME STEPS (E.G., DAILY AVG).
C
USE GLOBAL
IF(ISSDBIN .GT. 0)THEN
IF( MOD(ITNWQ,ISMTSDT) .EQ. 0 )THEN
NREC4 = NREC4+1
Found Structure @ 97329
SUBROUTINE WWQNC
C
C CHANGE RECORD
C WRITE INFORMATION OF NEGATIVE WQ STATE VARIABLES (UNIT IWQONC).
C
USE GLOBAL
CHARACTER*5 WQVN(NTSWQVM)
DATA WQVN/
& 'BC ','BD ','BG ','RPOC','LPOC','DOC ','RPOP','LPOP',
Found Structure @ 97357
SUBROUTINE WWQRST
C
C CHANGE RECORD
C WRITE SPATIAL DISTRIBUTIONS AT THE END OF SIMULATION TO UNIT IWQORST.
C
USE GLOBAL
C
C WRITE ASCII RESTART FILE:
C
OPEN(1,FILE='WQWCRST.OUT',STATUS='UNKNOWN')
Found Structure @ 97399
SUBROUTINE WWQTS
C
C ** SHEN'S MODIFICATION TO OUTPUT MACROALGAE
C CHANGE RECORD
C WRITE TIME-SERIES OUTPUT: WQCHLX=1/WQCHLX
C
USE GLOBAL
C
REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WQVOUT
IF(.NOT.ALLOCATED(WQVOUT))THEN
Found Structure @ 97507
C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
SUBROUTINE WWQTSBIN
C
C**********************************************************************C
C WRITE TIME-SERIES OUTPUT: WQCHLX=1/WQCHLX TO BINARY FILE
C**********************************************************************C
Found Structure @ 98230
FUNCTION ZBRENT(ISMERR)
C
C USING BRENT'S METHOD, FIND THE ROOT OF A FUNC SEDFLUX KNOWN TO LIE
C BETWEEN RMIN & RMAX WITHIN AN ACCURACY OF TOL (P. 253 IN NUMERICAL
C RECIPE).
C
EXTERNAL SEDFLUX
PARAMETER (IZMAX=100,EPS=3.0E-8,TOL=1.0E-5,
& RMIN=1.0E-4,RMAX=100.0)
ISMERR = 0
A = RMIN
Found Entry @ 15100
ENTRY SHORT_WAVE_RADIATION(WSPD,TD,TAIR,CLD,ATMPR,SRO,SRON)
******* Input Conversions
IF(TD.LT.1.1.AND.IRELH(NASER).EQ.1)THEN
! *** TD IS RELATIVE HUMIDITY. CONVERT TO DEW POINT
! *** Jensen et al. (1990) ASCE Manual No. 70 (see pages 176 & 177)
! *** Ambient vapor pressure in kPa
VaporP=TD* 0.611*EXP(17.27*TAIR/(TAIR+237.3))
! *** Compute dewpoint temperature (Tdew) in C
Found Entry @ 15167
ENTRY EQUILIBRIUM_TEMPERATURE(SRON,ET,CSHE)
******* British units
! *** SRON Should already be adjusted for Shading & Reflection
SRO_BR = SRON*W_M2_TO_BTU_FT2_DAY
******* Equilibrium temperature and heat exchange coefficient
ET = TDEW_F
TSTAR = (ET+TDEW_F)*0.5
_