      PROGRAM Q2E3P1
C
C3P1      PROGRAM QUAL2E, VERSION 3.1  EPA ENHANCED VERSION 01/01/90
C3P12     PROGRAM QUAL2E, VERSION 3.12 EPA ENHANCED VERSION 01/11/91
C3P13     PROGRAM QUAL2E, VERSION 3.13 EPA ENHANCED VERSION 07/01/91
C3P14     PROGRAM QUAL2E, VERSION 3.12 EPA ENHANCED VERSION 01/01/92
C3P22     PROGRAM QUAL2E, VERSION 3.22 EPA ENHANCED VERSION 05/01/96
C3P1      GENERATES OUTPUT PLOT FILE (OSIM.DPL) AND INCLUDES
C3P1      MODIFICATIONS BY B. RODRIGUEZ,  LCB, AND OTHERS.
CQ2E
CQ2E        PROGRAM QUAL-2E, VERSION 3.0   EPA/NCASI ENHANCED VERSION
CQ2E
C                             QUAL-2 IS A SET OF INTERRELATED STREAM
C                             QUALITY ROUTING MODELS. IT HAS THE
C                             CAPABILITY TO ROUTE TEMP.,BOD/DO,
C                             NITROGEN SERIES, PHOSPHATE, ALAGE,
C                             COLIFORMS, ARBITRARY NON CONSERVATIVE, AND
C                             UP TO THREE CONSERVATIVE MINERALS
C                             THROUGH A FULLY-MIXED STREAM SYSTEM.
C                             THESE PARAMETERS CAN BE ROUTED ON AN
C                             INDIVIDUAL BASIS OR SIMULTANEOUSLY IN
C                             SUCH A COMBINATION AS THE USER MAY
C                             DESIRE. QUAL-2 ALSO HAS THE CAPABILITY
C                             TO COMPUTE THE FLOW AUGMENTATION REQED.
C                             TO MEET PRESELECTED MIMIMUM DO LEVELS.
C                             HYDRAULICS ARE CONSIDERED STEADY-STATE.
C
C3.0  QUAL2E, VERSION 3.0 (FEBRUARY 1987) INCORPORATES THE FOLLOWING MAJOR
C3.0    ENHANCEMENTS OVER VERSION 2.2 (AUGUST 1985).
C3.0      1. TEMPERATURE SIMULATIONS.
C3.0         A. STEADY STATE MODE: REACH VARIABLE LOCAL CLIMATOLOGY
C3.0            DATA CAN BE INPUT VIA A NEW DATA TYPE 5A.
C3.0         B. DYNAMIC (DIURNAL) MODE: LOCAL CLIMATOLOGICAL DATA
C3.0            MUST BE READ FROM A SEPARATE INPUT FILE.
C3.0         C. VERSION 3.0 WILL CORRECTLY READ VERSION 2.2 DATA
C3.0            FILES FOR STEADY STATE SIMULATIONS.
C3.0      2. DISSOLVED OXYGEN SIMULATIONS.  OBSERVED DO DATA CAN BE READ
C3.0         FROM A SEPARATE DATA FILE AND PLOTTED WITH THE SIMULATED
C3.0         DO VALUES IN SUBROUTINE PRPLOT.
C3.0      3. STEADY STATE CONVERGENCE CRITERION.  THIS CONVERGENCE
C3.0         CRITERION HAS BEEN CHANGED FROM AN ABSOLUTE ERROR TO A
C3.0         RELATIVE ERROR (1.0E-03).
CC
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 03/01/90
C3.1 - QUAL2E UPDATE                                                    03/01/90
C3.1   D. Disney, CSC                                                   03/01/90
C3.1   Version 3.10                                                     03/01/90
C3.1                                                                    03/01/90
C3.1   All VAX installation specific statements are indicated by the    03/01/90
C3.1   characters CVAX in columns 1 through 4.  Version 3.1 implements  03/01/90
C3.1   code restructure and file CONFIG.FIL.  This file is read by      03/01/90
C3.1   QUAL2E and contains the file storage path for files MSGFILE.DAT  03/01/90
C3.1   and UCODE.DAT.  These files can be used by multiple users in a   03/01/90
C3.1   shared installation of QUAL2E on VAX or networked PC systems.    03/01/90
C3.1   Version 3.1 implements the use of the FORTRAN INCLUDE file       03/01/90
C3.1   IOUNIT.INC.  This file contains all declarations for file I/O    03/01/90
C3.1   unit numbers.  All unit numbers are initialized in BLOCK.FOR.    03/01/90
C3.1   CHARCT.VAR was also modified to declare file storage path        03/01/90
C3.1   varialbles MFPATH and UCPATH.                                    03/01/90
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 03/01/90
C
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 01/09/91
C3.1 - QUAL2E UPDATE                                                    01/09/91
C3.1   D. Disney, CSC                                                   01/09/91
C3.1   Version 3.12                                                     01/09/91
C3.1                                                                    01/09/91
C3.1   Version 3.12 contains minor correctios to QUAL2E scientific code 01/09/91
C3.1   and corrections and improvements to file handling.  New error    01/09/91
C3.1   trapping routines and run time error messages were added to      01/09/91
C3.1   to OPEN statements to assist the user in identifying and         01/09/91
C3.1   correcting problems with file input and output (e.g. file not    01/09/91
C3.1   found, incorrect file name used).  Prompt for previously hard    01/09/91
C3.1   coded plot data file name (OSIM.DPL) added 01/11/91.             01/09/91
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 01/09/91
C
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 01/01/92
C3.1 - QUAL2E UPDATE                                                    01/01/92
C3.1   D. Disney, CSC                                                   01/01/92
C3.1   Versions 3.13, 3.14                                              01/01/92
C3.1                                                                    01/01/92
C3.1   Versions contain minor correctios to QUAL2E scientific code.     01/01/92
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 01/01/92
C
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 07/01/92
C3.1 - QUAL2E UPDATE                                                    07/01/92
C3.1   D. Disney, CSC                                                   07/01/92
C3.1   Version 3.15                                                     07/01/92
C3.1                                                                    07/01/92
C3.1   Added SVS FORTRAN specific statements (CSVS, etc.).              07/01/92
C3.1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 07/01/92
C
        EXTERNAL BLKINI
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
      CHARACTER*64 DONAME
      CHARACTER*4 LTITLE(20),DTITLE(20)
C +++++
C +   The following declaration statements added by D. Disney, CSC
C +   01/06/86 to correct Ryan-McFarland FORTRAN 77 compile error
C +   and to implement logic and code for MSGFILE.DAT and UCODE.DAT
C +   file path names.
C +
      CHARACTER*1  ANS, BLANK, ASTRIK
C +++++
C      CHARACTER*4  ENDT,ENDA,YES
C +++++
      CHARACTER*70 DUMNAM
C +++++
C      CHARACTER*40 ENDMSG
C +++++
C +
C +   End of change.
C +++++
C3P1    OUTPUT INTERFACE
      CHARACTER*13 OTITL(85)
      CHARACTER*8 BODU
      CHARACTER*7 UNITS
      CHARACTER*4 UBOD
C3P1
C +++++
C      DIMENSION DATA(ML,25)
C +++++
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/, BLANK/' '/,
C     *     ASTRIK/'*'/
      DATA BLANK/' '/, ASTRIK/'*'/
      DATA DONAME / '
     1             ' /
C +++++
C +++++
C      DATA ENDMSG/'                                        '/
C +++++
C
C3P1    OUTPUT INTERFACE  6/89  (LCB)
      DATA UBOD,UNITS,BODU / ' 5-D','ENGLISH','ULTIMATE'/
C
      DATA OTITL(1),OTITL(2),OTITL(3),OTITL(4),OTITL(5),OTITL(6) /
     1 '  ELE ORD NUM','    REACH NUM','  ELEMENT NUM','     PLOT NUM',
     2 '  ELE BGN LOC','  ELE END LOC' /
      DATA OTITL(7),OTITL(8),OTITL(9),OTITL(10),OTITL(11),OTITL(12) /
     1 '         FLOW','   POINT SRCE', '    INCR FLOW','     VELOCITY',
     2 '  TRAVEL TIME','        DEPTH' /
      DATA OTITL(13),OTITL(14),OTITL(15),OTITL(16),OTITL(17),OTITL(18) /
     1 '    TOP WIDTH','       VOLUME','  BOTTOM AREA','  X-SECT AREA',
     2 '  DSPRSN COEF','       DO SAT' /
      DATA OTITL(19),OTITL(20),OTITL(21),OTITL(22),OTITL(23),OTITL(24) /
     1 '   REAIR OPTN','  OXYGN REAIR','    BOD DECAY','     BOD SETT',
     2 '     SOD RATE','   ORGN DECAY' /
      DATA OTITL(25),OTITL(26),OTITL(27),OTITL(28),OTITL(29),OTITL(30) /
     1 '    ORGN SETT','    NH3 DECAY','     NH3 SRCE','    NO2 DECAY',
     2 '   ORGP DECAY','    ORGP SETT' /
      DATA OTITL(31),OTITL(32),OTITL(33),OTITL(34),OTITL(35),OTITL(36) /
     1 '    DISP SRCE','   COLI DECAY','    ANC DECAY','     ANC SETT',
     2 '     ANC SRCE','  TEMPERATURE' /
      DATA OTITL(37),OTITL(38),OTITL(39),OTITL(40),OTITL(41),OTITL(42) /
     1 '   CONS MIN-1','   CONS MIN-2','   CONS MIN-3','  DISS OXYGEN',
     2 '          BOD','    ORGANIC-N' /
      DATA OTITL(43),OTITL(44),OTITL(45),OTITL(46),OTITL(47),OTITL(48) /
     1 '    AMMONIA-N','    NITRITE-N','    NITRATE-N','        SUM-N',
     2 '    ORGANIC-P','    DISSLVD-P' /
      DATA OTITL(49),OTITL(50),OTITL(51),OTITL(52),OTITL(53),OTITL(54) /
     1 '        SUM-P','     COLIFORM','  ARBTRY NCON','   CHLRPHYL-A',
     2 '  ALGY GROWTH','    ALGY RESP' /
      DATA OTITL(55),OTITL(56),OTITL(57),OTITL(58),OTITL(59),OTITL(60) /
     1 '    ALGY SETT','  A-P/R RATIO','  AGY NET P-R','  NH3 FRC NUP',
     2 '  LITE EXT CO','   AGY L-FACT' /
      DATA OTITL(61),OTITL(62),OTITL(63),OTITL(64),OTITL(65),OTITL(66) /
     1 '   AGY N-FACT','   AGY P-FACT','   DO DEFICIT','   DAM DO INP',
     2 '  N-INHB FACT','  DOMB-F FUNC' /
      DATA OTITL(67),OTITL(68),OTITL(69),OTITL(70),OTITL(71),OTITL(72) /
     1 '   DOMB-REAIR','    DOMB-CBOD','     DOMB-SOD','   DOMB - P-R',
     2 '    DOMB-NH3N','    DOMB-NO2N' /
      DATA OTITL(73),OTITL(74),OTITL(75),OTITL(76),OTITL(77),OTITL(78) /
     1 '  RCH ELEVATN','  D-ATTN COEF','   CLOUD FACT','  D-BULB TEMP',
     2 '  W-BULB TEMP','  AT-PRESSURE' /
      DATA OTITL(79),OTITL(80),OTITL(81),OTITL(82),OTITL(83),OTITL(84) /
     1 '     WIND VEL','    SOLAR RAD','   L WAVE RAD','   W SURF RAD',
     2 '   CONDUCTION','  EVAPORATION' /
      DATA OTITL(85) / '  NET H-BLNCE' /
C3P1
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +++++ End declarations and data initialization. ++++++++++++++++++++++
C +++++ Begin executable statement area. +++++++++++++++++++++++++++++++
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
CVAX - DWD for US EPA (CVAX and CSAL)
CVAX   Date: Friday, 25 May 1990.  Time: 08:45:58.
CVAX   Remove and the following OPEN statement for
CVAX   VAX, Salford, SVS, AND F7L FORTRAN.
CPC
CPC      OPEN(UNIT=CONOUT,STATUS='UNKNOWN',FILE='CON')
CPC 
      CALL CLRSCR
      WRITE(CONOUT,5)
CTGC    5 FORMAT(///////////,
CTGC     1 '                 Performing QUAL2E program initialization.')
    5 FORMAT(/,
     1 '                 Performing QUAL2E program initialization.')
CTGC Clrscr OK
C
C +++++
      CALL INIT
CTGC Init OK
C +++++
C
C +++++
C +   Configuration file CONFIG.FIL logic and code added by
C +   D. Disney, CSC, for storage of MFGFILE.DAT and
C +   UCODE.DAT files.  These files can be shared by multiple
C +   QUAL2E users from a common subdirectory and drive.
C +   This option applies to VAX and networked PC systems.
C +   Date: Monday, 26 February 1990.  Time: 12:51:58.
C +
C +   NOTE: The following variables are initialized by DATA
C +         statements in the file BLOCK.FOR:
C +
C +         Variable Name   Initial Value   Type Declaration
C +         -------------   -------------   ----------------
C +         IM, IU          1               Integer
C +         MFPATH          64 spaces       Character
C +         UCPATH          64 spaces       Character
C +
      OPEN(UNIT=CFGFIL,FILE='CONFIG.FIL',ERR=17,STATUS='OLD',
     1     FORM='FORMATTED',ACCESS='SEQUENTIAL')
C
      READ(UNIT=CFGFIL,END=16,ERR=16,FMT=5000)MFPATH
      DO 10 I = 64,1,-1
         IF (MFPATH(I:I).EQ.BLANK) GO TO 10
         IM = I
         GO TO 11
   10 CONTINUE
C
   11 READ(UNIT=CFGFIL,END=16,ERR=993,FMT=5000)UCPATH
      DO 14 I = 64,1,-1
         IF (UCPATH(I:I).EQ.BLANK) GO TO 14
         IU = I
         GO TO 16
   14 CONTINUE
C
 5000 FORMAT(1X,A64)
C
   16 CLOSE(UNIT=CFGFIL,ERR=995)
   17 CONTINUE
C
      IF (IM.EQ.1.AND.MFPATH(1:1).EQ.BLANK) THEN
          OPEN(UNIT=MSGFIL,FILE='MSGFILE.DAT',STATUS='OLD',
     1         ERR=997,FORM='FORMATTED',ACCESS='SEQUENTIAL')
      ELSE
          OPEN(UNIT=MSGFIL,FILE=MFPATH(1:IM)//'MSGFILE.DAT',
     1         ERR=997,STATUS='OLD',FORM='FORMATTED',
     2         ACCESS='SEQUENTIAL')
      ENDIF
C +
C +   End of change.
C +++++
C
C +++++
C  20   CALL CLRSCR
C       CALL CLRSCR
C +++++
C        INCLUDE 'ANNOUN.INC'
C +++++
C +   Code to open and process run supervisor file added by
C +   D. Disney, CSC.
C +   Date: Wednesday, 7 March 1990.  Time: 09:01:17.
C +   Date: Friday, 11 January 1991.  Time: 09:01:07.
C +   Array CHARACTER*64 FILNAM(10) holds file names to be
C +   processed - FILNAM declared in CHARCT.VAR.  Array
C +   FILNAM initialized to blanks in BLOCK.FOR or BLOCKUNC.FOR.
C +   File name storage locations are:
C +
C +   FILNAM(1) - input data file name
C +   FILNAM(2) - output results file name
C +   FILNAM(3) - observed DO input data file for plotting
C +   FILNAM(4) - uncertainty (UNCAS) input specification file name
C +   FILNAM(5) - uncertainty (UNCAS) input variance file
C +   FILNAM(6) - local climatology input file name (dynamic simul)
C +   FILNAM(7) - scratch BASE.DAT file created by program
C +   FILNAM(8) - scratch STORE.DAT file created by program
C +   FILNAM(9) - output plot data file (previously hard coded as OSIM.DPL)
C +   FILNAM(10)- not used; can be used for future expansion
C +
C
      OPEN(UNIT=SUPFIL,FILE='QUAL2E.SUP',ERR=240,STATUS='OLD',
     1     FORM='FORMATTED',ACCESS='SEQUENTIAL')
C
      CALL CLRSCR
      CALL GETMSG(51,MSGFIL)
C
   21 CONTINUE
      READ(UNIT=SUPFIL,END=23,ERR=22,FMT=4999)DUMNAM
 4999 FORMAT(A70)
      IF(DUMNAM(1:1).EQ.ASTRIK) GO TO 21
      IF(DUMNAM(1:1).EQ.BLANK)  GO TO 21
      IF(DUMNAM(1:5).EQ.'INPUT') THEN
         FILNAM(1) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'OUTPT') THEN
         FILNAM(2) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'OBSDO') THEN
         FILNAM(3) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'UNCAS') THEN
         FILNAM(4) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'VARIA') THEN
         FILNAM(5) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'CLIMT') THEN
         FILNAM(6) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'BASED') THEN
         FILNAM(7) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'STORE') THEN
         FILNAM(8) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'OSIMO') THEN
         FILNAM(9) = DUMNAM(7:70)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'DISYN') THEN
         DISPYN    = DUMNAM(7:7)
         GO TO 21
      ENDIF
      IF(DUMNAM(1:5).EQ.'RETRN') THEN
         RETURN    = DUMNAM(7:7)
         GO TO 21
      ENDIF
C
      GO TO 23
C
   22 CALL CLRSCR
      CALL GETMSG(49,MSGFIL)
      CLOSE(UNIT=SUPFIL)
      GO TO 9999
C
   23 CLOSE(UNIT=SUPFIL)
  240 CALL CLRSCR
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      WRITE (CONOUT,5555) VERNUM
 5555 FORMAT(/,
     1 15X,'#################################################',/,
     2 15X,'#                                               #',/,
     3 15X,'#                    QUAL2E                     #',/,
     4 15X,'#                                               #',/,
     5 15X,'#           ',A26,'          #',/,
     6 15X,'#                                               #',/,
     7 15X,'#################################################',/,
     8 15X,'#                                               #',/,
     9 15X,'#           User should register with:          #',/,
     1 15X,'#                                               #',/,
     2 15X,'#    Center for Exposure Assessment Modeling    #',/,
     3 15X,'#     National Exposure Research Laboratory     #',/,
     4 15X,'#          Ecosystems Research Division         #',/,
     5 15X,'#      U.S. Environmental Protection Agency     #',/,
     6 15X,'#            960 College Station Road           #',/,
     7 15X,'#           Athens, Georgia 30605-2700          #',/,
     8 15X,'#              Voice: (706)/546-3549            #',/,
     9 15X,'#          e-mail: ceam@epamail.epa.gov         #',/,
     1 15X,'# End-of-Life -- Above Contact Obsolete         #',/,
     2 15X,'# 2018-1005 Modify/Compile for Wrapper          #',/,
     3 15X,'# 2018-1005 Concatenate into single source      #',/,
     4 15X,'# 2018-1005 Change non-standard \ into /        #',/,
     5 15X,'# 2018-1005 Remove carriage control directives  #',/,
     5 15X,'# 2018-1005 Modify for Shell-In-A-Box           #',/,
     6 15X,'#################################################',/)
C
CPC
      WRITE (CONOUT,5556)
 5556 FORMAT(/,
     1 15X,'#################################################',/,
     2 15X,'# BUFFALO Press <Enter> key to continue         #',/,
     3 15X,'#################################################')

        IF (RETURN.EQ.'N') READ(CONIN,1111)ANS
 1111   FORMAT(A1)
        WRITE(CONOUT,*)ANS
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C

      CALL CLRSCR
      WRITE(CONOUT,2200)
 2200 FORMAT(////////////////////////)
C
C   23 CLOSE(UNIT=SUPFIL)
C
   24 CONTINUE
C
      IF(FILNAM(1)(1:1).EQ.BLANK) THEN
         WRITE(CONOUT,2345)
2345     FORMAT('** Enter name of QUAL2E input data file:  ',/)
CSAL2345     FORMAT('** Enter name of QUAL2E input data file:  ')
CVAX2345     FORMAT('$','** Enter name of QUAL2E input data file:  ')
         READ(CONIN,5432) FILNAM(1)
5432     FORMAT(A64)
      ENDIF
C
      OPEN (UNIT=NI,FILE=FILNAM(1),STATUS='OLD',ERR=996)
C
   25 CONTINUE
C
      IF(FILNAM(2)(1:1).EQ.BLANK) THEN
         WRITE(CONOUT,3456)
3456     FORMAT(/,'** Enter name of QUAL2E output file or LPT1:  ',/)
CSAL3456     FORMAT(/,'** Enter name of QUAL2E output file or LPT1:  ')
CVAX3456     FORMAT(/,'$','** Enter name of QUAL2E output file:  ')
         READ(CONIN,5432) FILNAM(2)
CTGC         WRITE(*,*) FILNAM(2)
      ENDIF
C
      IF(FILNAM(2)(1:1).EQ.BLANK) GOTO 9961
CPC
CPC      OPEN(UNIT=NJ,FILE=FILNAM(2),STATUS='UNKNOWN',ERR=9961)
CPC
CSVS
CSVS      OPEN(UNIT=NJ,FILE=FILNAM(2),STATUS='UNKNOWN',ERR=9961,
CSVS     -     FORM='PRINTER')
CSVS
CF7L
C23456789012345678921234567893123456789412345678951234567896
      OPEN(UNIT=NJ,FILE=FILNAM(2),STATUS='UNKNOWN',ERR=9961)
CTGC     &     CARRIAGECONTROL='FORTRAN')
CF7L
CSAL
CSAL      OPEN(UNIT=NJ,FILE=FILNAM(2),STATUS='UNKNOWN',ERR=9961,
CSAL     -     FORM='PRINTER')
CSAL
C
C +++++
C +   Code and logic added by D. Disney, CSC to prompt
C +   user for option to display detailed run time
C +   status message on monitor screen.
C
      IF(DISPYN.EQ.BLANK) THEN
3458     WRITE(CONOUT,3459)
3459     FORMAT(/,'** Display detailed run-time status',
     *              ' messages on monitor screen? (Y/N):  ',/)
CSAL3459     FORMAT(/,'** Display detailed run-time status',
CSAL     *              ' messages on monitor screen? (Y/N):  ')
CVAX3459     FORMAT(/,'$','** Display detailed run-time status',
CVAX     *                  ' messages on monitor screen? (Y/N):  ')
         READ(CONIN,3460) DISPYN
3460     FORMAT(A1)
         IF(DISPYN.EQ.'Y'.OR.DISPYN.EQ.'y'.OR.
     1      DISPYN.EQ.'N'.OR.DISPYN.EQ.'n')   GOTO 3469
         WRITE(CONOUT,3462)
3462     FORMAT(/,'** ERROR ON INPUT',/,
     1            '   Please enter Y, y, N, or n only - Try again.')
         GOTO 3458
3469     CONTINUE
      ENDIF
C
      IF(DISPYN.EQ.'y') DISPYN='Y'
      IF(DISPYN.EQ.'n') DISPYN='N'
C +
C +   End of change.
C +++++
C3.0
       INTOUT=2
C3.0
CCC             NCASI Commentary, MAIN - Section B. (QUAL2 Steps 2-0,
CCC                 3-0, and 4-0).
CCC                     B. CALL INDATA.  Return with all required
CCC                         input data, except local climatology,
CCC                         and plot data.
C3P0
      IF(DISPYN.EQ.'N') CALL CLRSCR
      IF(DISPYN.EQ.'N') CALL GETMSG(1,MSGFIL)
C3P0
      CALL INDATA
C3.0
C3.0     READ INPUT FILE NAME CONTAINING THE LOCAL CLIMATOLOGY DATA FOR
C3.0        DYNAMIC(DIURNAL) SIMULATIONS.
C3.0
      IF(ISS.GT.0) GO TO 41
      IF(MODOPT(2).EQ.0.AND.MODOPT(4).EQ.0) GO TO 41
C
C      IF(ISS.GT.0.OR.(MODOPT(2).EQ.0.AND.MODOPT(4).EQ.0)) GO TO 41
C
      CALL CLRSCR
C
      ANS = BLANK
   29 CONTINUE
C
      IF(FILNAM(6)(1:1).EQ.BLANK) THEN
         IF (ANS .EQ. BLANK) THEN
             WRITE(CONOUT,30)
30           FORMAT(//////////////////////,
     *        '** Enter name of file containing local climatology',
     *      /,'             data for dynamic (DIURNAL) simulation:  ',/)
CSAL30           FORMAT(//////////////////////,
CSAL     *        '** Enter name of file containing local climatology',
CSAL     *      /,'             data for dynamic (DIURNAL) simulation:  ')
CVAX30           FORMAT(//////////////////////,
CVAX     *    '$','** Enter name of file containing local climatology',
CVAX     *  /,'$','             data for dynamic (DIURNAL) simulation:  ')
         ENDIF
         IF (ANS .EQ. 'E') THEN
             WRITE(CONOUT,31)
31           FORMAT(/,
     *        '** Enter name of file containing local climatology',
     *      /,'             data for dynamic (DIURNAL) simulation:  ',/)
CSAL31           FORMAT(/,
CSAL     *        '** Enter name of file containing local climatology',
CSAL     *      /,'             data for dynamic (DIURNAL) simulation:  ')
CVAX31           FORMAT(/,
CVAX     *    '$','** Enter name of file containing local climatology',
CVAX     *  /,'$','             data for dynamic (DIURNAL) simulation:  ')
         ENDIF
C
         READ(CONIN,5432) FILNAM(6)
C         IF (DISPYN.EQ.'Y') CALL CLRSCR
      ENDIF
C
C      NI2=2
      IF(FILNAM(6)(1:1).EQ.BLANK) GOTO 998
      OPEN(UNIT=NI2,STATUS='OLD',ERR=998,FILE=FILNAM(6))
      ANS = BLANK
C
      READ(NI2,39) (LTITLE(J),J=1,20)
39    FORMAT(20A4)
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') WRITE(CONOUT,40) (LTITLE(J),J=1,20)
40    FORMAT(//////////,
     * 13X,'Reading LCD data for dynamic (DIURNAL) simulation:',/,
     * 5X,20A4)
41    CONTINUE
C
      IF(DISPYN.EQ.'N'.AND.ISS.GT.0) CALL GETMSG(40,MSGFIL)
C
C      IF(DISPYN.EQ.'N'.AND.
C     *  (ISS.GT.0.OR.(MODOPT(2).EQ.0.AND.MODOPT(4).EQ.0)))
C     *   CALL GETMSG(40,MSGFIL)
C
      CALL Q2EZ
C3.0
      IF(ISS.GT.0) GO TO 555
      IF(MODOPT(2).EQ.0.OR.MODOPT(4).EQ.0) GO TO 555
      CLOSE(UNIT=NI2)
 555  CONTINUE
C3.0
CCC             NCASI Commentary, MAIN - Section K.
CCC                     K. Write final summary.
C +++++
      CALL CLRSCR
      IF(DISPYN.EQ.'N') CALL GETMSG(41,MSGFIL)
      IF(DISPYN.EQ.'Y') CALL GETMSG(29,MSGFIL)
C +++++
      CALL WRPT3A (NPAGE)
      CALL WRPT3B (NPAGE)
C3.0
      IF(IPLOT.EQ.0) GO TO 556
C3.0
C3.0     TEST WHETHER DO DATA ARE AVAILABLE FOR PLOTTING
C3.0
      ANS = BLANK
      IF(FILNAM(3).EQ.'NUL') THEN
         KDATA=0
         GO TO 353
      ENDIF
   42 CONTINUE
      IF(FILNAM(3)(1:1).EQ.BLANK) THEN
         IF (ANS .EQ. BLANK) THEN
             CALL CLRSCR
C +++++
C335          WRITE(CONOUT,336)
             WRITE(CONOUT,336)
C +++++
336          FORMAT(///////////////////////,
     1             '** Enter name of file containing',
     2             ' observed DO data: (Enter=none) ',/)
CSAL336          FORMAT(///////////////////////,
CSAL     1             '** Enter name of file containing',
CSAL     2             ' observed DO data: (Enter=none) ')
CVAX336          FORMAT(///////////////////////,
CVAX     1             '$','** Enter name of file containing',
CVAX     2                 ' observed DO data: (Enter=none) ')
         ENDIF
         IF (ANS .EQ. 'E') THEN
             WRITE(CONOUT,337)
337          FORMAT(/,
     1              '** Enter name of file containing',
     2              ' observed DO data: (Enter=none) ',/)
CSAL337          FORMAT(/,
CSAL     1              '** Enter name of file containing',
CSAL     2              ' observed DO data: (Enter=none) ')
CVAX337          FORMAT(/,
CVAX     1              '$','** Enter name of file containing',
CVAX     2                  ' observed DO data: (Enter=none) ')
         ENDIF
C
         READ(CONIN,5432) FILNAM(3)
C         NI2 = 2
      ENDIF
C
      IF(FILNAM(3)(1:1).EQ.BLANK) THEN
         KDATA=0
         GO TO 353
      ENDIF
C
      OPEN(UNIT=NI2,STATUS='OLD',ERR=999,FILE=FILNAM(3))
      ANS = BLANK
C
      KDATA = 1
      READ(NI2,339) (DTITLE(J),J=1,20)
339   FORMAT(20A4)
      DONAME = FILNAM(3)
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') WRITE(CONOUT,340) DONAME,(DTITLE(J),J=1,20)
340   FORMAT(//////////,17X,'Reading observed DO data file: ',A12,
     1       /,5X,20A4)
353   CONTINUE
      CALL CLRSCR
      CALL GETMSG(30,MSGFIL)
      CALL PRPLOT(KDATA)
      IF(KDATA.EQ.1) CLOSE(UNIT=NI2)
556   CONTINUE
C3.0
      CLOSE(UNIT=NI)
C3P1
C3P1   OUTPUT INTERFACE - WRITE DATA FILE
C3P1   OPEN statement syntax changed DWD
C3P1   Date: Monday, 4 June 1990.  Time: 07:58:31.
C3P12  Date: Friday, 11 January 1991.  Time: 09:02:15.
C3P12
C
      ANS = BLANK
      IF(FILNAM(9)(1:3).EQ.'NUL') GO TO 753
   50 CONTINUE
      IF(FILNAM(9)(1:1).EQ.BLANK) THEN
         IF (ANS .EQ. BLANK) THEN
             CALL CLRSCR
             WRITE(CONOUT,3457)
3457         FORMAT(///////////////////////,
     1              '** Enter name of QUAL2E output plot file:  ',/)
CSAL3457         FORMAT(///////////////////////,
CSAL     1              '** Enter name of QUAL2E output plot file:  ')
CVAX3457         FORMAT(///////////////////////,
CVAX     1             '$','** Enter name of QUAL2E output plot file:  ')
         ENDIF
         IF (ANS .EQ. 'E') THEN
             WRITE(CONOUT,3461)
3461         FORMAT(/,
     1              '** Enter name of QUAL2E output plot file:  ',/)
CSAL3461         FORMAT(/,
CSAL     1              '** Enter name of QUAL2E output plot file:  ')
CVAX3461         FORMAT(/,
CVAX     1             '$','** Enter name of QUAL2E output plot file:  ')
         ENDIF
C
         READ(CONIN,5432) FILNAM(9)
      ENDIF
C3P12
C
      IF(FILNAM(9)(1:1).EQ.BLANK) GOTO 9991
      OPEN(UNIT=NI,FILE=FILNAM(9),STATUS='UNKNOWN',
     1     FORM='FORMATTED',ACCESS='SEQUENTIAL',ERR=9991)
CVAX
CVAX      OPEN(UNIT=NI,FILE=FILNAM(9),STATUS='UNKNOWN',
CVAX     1     FORM='FORMATTED',ACCESS='SEQUENTIAL',
CVAX     2     CARRIAGECONTROL='LIST')
CVAX
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(52,MSGFIL)
      ANS = BLANK
C3P1
C3P1      OPEN(UNIT=NI,FILE='OSIM.DPL',STATUS='UNKNOWN')
C3P1
      DO 700 I=1,2
700   WRITE(NI,701) (TITLE(I,J),J=1,20)
701   FORMAT(2X,20A4)
      IF(METOUT.GT.0) UNITS = 'METRIC '
      IF(TITLE(7,6).EQ.UBOD) BODU = '5-DAY   '
      WRITE(NI,710) UNITS,BODU
710   FORMAT(2X,'OUTPUT UNITS = ',A7,'  ;  BOD = ',A8)
      WRITE(NI,721) (OTITL(J),J=1,85)
721   FORMAT(9(10A13/))
      DO 750 I=1,NCELLS
      WRITE(NI,751) I
751   FORMAT(I6)
750   WRITE(NI,752) (OSIM(I,J),J=1,85)
752   FORMAT(9(10E13.5/))
      CLOSE(UNIT=NI)
753   CONTINUE
C3P1
      CALL CLRSCR
      CALL GETMSG(3,MSGFIL)
      CLOSE(UNIT=MSGFIL)
      CLOSE(UNIT=NJ)
C
      GO TO 9999
C +++++
C +
C +   Statements 991 through 995 added by D. Disney
C +   Date: Tuesday, 27 February 1990.  Time: 09:27:03.
C +   These statments display error or warning messages
C +   on the monitor concerning the opening or reading of
C +   the file storage configuration file CONFIG.FIL.
C +
C 991  CALL CLRSCR
C      WRITE(CONOUT,9912)
C 9912 FORMAT(/////////////////////,
C     1       'Error opening file storage configuration file',
C     2     /,'                 CONFIG.FIL',
C     3     /,'Contact CEAM technical support (706/546-3549)',/)
C      GO TO 9999
C
C 992  CALL CLRSCR
C      WRITE(CONOUT,9921)
C 9921 FORMAT(/////////////////////,
C     1       'Error reading file storage configuration file',
C     2     /,'                 CONFIG.FIL',
C     3     /,'Error reading MSGFILE.DAT storage path record.',
C     4     /,'Contact CEAM technical support (706/546-3549)',/)
C      GO TO 9999
C
 993  CALL CLRSCR
      WRITE(CONOUT,9931)
 9931 FORMAT(/////////////////////,
     1       'Error reading file storage configuration file',
     2     /,'                 CONFIG.FIL',
     3     /,' Error reading UCODE.DAT storage path record.',
     4     /,'Contact CEAM technical support (706/546-3549)',/)
      GO TO 9999
C
C 994  CALL CLRSCR
C      WRITE(CONOUT,9941)
C 9941 FORMAT(/////////////////////,
C     1       'Error reading file storage configuration file',
C     2     /,'                 CONFIG.FIL',
C     3     /,' End of file CONFIL.FIG reached prematurely.',
C     4     /,'Contact CEAM technical support (706/546-3549)',/)
C      GO TO 9999
C
 995  CALL CLRSCR
      WRITE(CONOUT,9951)
 9951 FORMAT(/////////////////////,
     1       'Error closing file storage configuration file',
     2     /,'                 CONFIG.FIL',
     3     /,'Contact CEAM technical support (706/546-3549)',/)
      GO TO 9999
C +++++
C +
C +   Statements 996 through 999 added by D. Disney
C +   Date: Wednesday, 9 January 1991.  Time: 09:17:50.
C +   These statments display error messages on the
C +   monitor concerning the opening of the data, run
C +   time message, DO, and DIURNL input files.
C +
C
 996  WRITE(CONOUT,9952)FILNAM(1)
 9952 FORMAT(/,
     1       '** ERROR OPENING INPUT DATA FILE',
     2     /,'   ',A64,
     3     /,'   Try another file name or press <Ctrl>',
     4           '<Break> to stop.',/)
      FILNAM(1)(1:1)=BLANK
      GO TO 24
C
 9961 WRITE(CONOUT,9956)FILNAM(2)
 9956 FORMAT(/,
     1       '** ERROR OPENING OUTPUT DATA FILE',
     2     /,'   ',A64,
     3     /,'   Enter file name or LPT1 at present cursor position.',
     4     /,'   Try another file name or LPT1 or press <Ctrl>',
     5           '<Break> to stop.',/)
      FILNAM(2)(1:1)=BLANK
      GO TO 25
C
 9991 WRITE(CONOUT,9957)FILNAM(9)
 9957 FORMAT(/,
     1       '** ERROR OPENING OUTPUT PLOT DATA FILE',
     2     /,'   ',A64,
     3     /,'   Enter file name at present cursor position.',
     4     /,'   Try another file name or press <Ctrl>',
     5           '<Break> to stop.',/)
      ANS = 'E'
      FILNAM(9)(1:1)=BLANK
      GO TO 50
C
 997  CALL CLRSCR
      WRITE(CONOUT,9953)
 9953 FORMAT(/////////////////////,
     1       '** ERROR OPENING RUN TIME MESSAGE FILE',
     2     /,'   MSGFILE.DAT',
     3     /,'   Contact CEAM technical support (706/546-3549)',/)
      GO TO 9999
C
 998  WRITE(CONOUT,9954)FILNAM(6)
 9954 FORMAT(/,
     1       '** ERROR OPENING LOCAL CLIMATOLOGY INPUT DATA FILE',
     2     /,'   for dynamic (DIURNAL) simulation',
     3     /,'   ',A64,
     4     /,'   Try another file name or press <Ctrl><Break> to',
     5           ' stop.',/)
      ANS = 'E'
      FILNAM(6)(1:1)=BLANK
      GO TO 29
C
 999  WRITE(CONOUT,9955)FILNAM(3)
 9955 FORMAT(/,
     1       '** ERROR OPENING OBSERVED DO INPUT DATA FILE',
     2     /,'   ',A64,
     3     /,'   Try another file name or press <Ctrl><Break> to',
     4           ' stop.',/)
      ANS = 'E'
      FILNAM(3)(1:1)=BLANK
      GO TO 42
C +
C +   End of change.
C +++++
C
 9999 CONTINUE
CSAL
CSAL      CLOSE(UNIT=CONOUT)
CSAL
      STOP
C
      END
        BLOCK DATA BLKINI
C
C               FILE: Q2EDATA.FOR
C               DATA BLOCK PROGRAM FOR QUAL2E VERSION 3.0
C                    (COMPATABLE WITH QUAL2E-UNCAS)
C
C               INCLUDE ALL COMMON AREAS.
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C          DECLARE DATA IN 'MAIN' DATA.
C
        DATA            AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA,LAVOPT,LFNOPT,
     *                  LGROPT
     *                  /47*0.0,3*0/
        DATA            AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
     *                  /35*0.0,16*0/
        DATA            TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
     *                  /0.0,17*0/
C
        DATA            PI/3.141628/
C
C          DECLARE DATA IN 'ARRAYS' COMMON.
C
        DATA            ADAM,BDAM,FDAM
     *                  /MNUDAM*0.0,MNUDAM*0.0,MNUDAM*0.0/
CBR     *                  /30*0.0/
        DATA            BATSUN,CONSLB,DAMO2,
     *                  HDAM,R,SUN,TDLH,
     *                  MODOPT
CBR     *                  /123*0.0,10*0/
     *                  /25*0.0,3*0.0,MNUDAM*0.0,MNUDAM*0.0,25*0.0,
     *                   25*0.0,MR*0.0,10*0/
      DATA         ALFA1/-0.105,-0.161,-0.260,-0.360,-0.503,
     $             -0.671,-0.892,-1.144,-1.474,-1.842,
     A             -2.318,-2.858,-3.504,-4.264,-5.146,
     B             -6.202,-7.375,-8.767,-10.342,-12.162,-14.214/
      DATA         BETA1/0.0088,0.0102,0.0124,0.0144,0.0170,
     $             0.0198,0.0232,0.0268,0.0312,0.0358,
     A             0.0414,0.0474,0.0542,0.0618,0.0702,
     B             0.079,0.090,0.107,0.114,0.128,0.143/
      DATA         ALFA2/71.84,70.80,69.63,68.33,66.90,65.34,
     $             63.39,61.43,59.33,56.93,54.38,51.68,
     A             48.83,45.43,42.28,38.59,34.76,30.70,26.39,
     B             21.83,17.02/
      DATA         BETA2/0.826,0.852,0.878,0.904,0.930,0.956,
     $             0.986,1.014,1.042,1.072,1.102,1.132,
     B             1.162,1.196,1.226,1.259,1.292,1.326,1.361,
     B             1.396,1.431/
C3P1
      DATA         OSIM      /MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     * MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0./
C3P1
C
C          DECLARE DATA IN 'CHARCT' COMMON.
C
        DATA            HWTRID,RCHID,TITLE
     *        / MH*'    ',MH*'    ',MH*'    ',MH*'    ',MH*'    ',
     *          MR*'    ',MR*'    ',MR*'    ',MR*'    ',MR*'    ',
     *         440*'    ' /
C
C +++++
        DATA            DISPYN / 'N' /, RETURN / 'N' /
        DATA MFPATH,UCPATH
     */2*
     *'                                                                '
     */
        DATA FILNAM
     */6*
     *'                                                                '
     *,
     *'BASE.DAT                                                        '
     *,
     *'STORE.DAT                                                       '
     *,
     *2*
     *'                                                                '
     */
C
C +------------------------------------------------------------------------+
C |                              1         2                               |
C |                    [12345678901234567890123456] -- Version field scale.|
C +------------------------------------------------------------------------+
         DATA VERNUM / 'Version 3.22  --  May 1996'/
c         DATA VERNUM / 'Version 3.21  -  Feb. 1995'/
C         DATA VERNUM / 'Version 3.20 - March, 1994'/
C         DATA VERNUM / 'Ver 3.15 (Beta) April 1993'/
C
C +++++
C
C               DECLARE DATA IN THE 'COMPRT' COMMON.
C
        DATA            FLOW,VEL,TRVTM,DEPTH,
     *                  EWIDTH,VOLSEG,BAREA,XAREA,DL,XK2,CORDO,
     *                  T,CONS,DO2,BOD,CNH2,CNH3,CNO2,
     *                  CNO3,SUMN,PORG,PHOS,SUMP,COLI,ANC,ALGAE,
     *                  GROWTH,APR,APMR,PRF,EXTC,AGFL,AGFN,AGFP
     *         /MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0./
        DATA            A,AGYSET,B,C,DOSAT,DTOVCL,G,HSNET,K1,
     *                  K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG,
     *                  RESPRR,S,SCPHOS,SETNH2,SOD,SRANC,SRCNH3,
     *                  STANC,STPORG,W,X,Z,JDAM,JT
     *         /MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,MC*0.,
     *          MC*0.,MC*0.,MC*0,MC*0 /
C
C               DECLARE DATA IN THE 'HDWTRS' COMMON.
C
        DATA            HWFLOW,HWTEMP,HWDO,HWBOD,
     *                  HWCONS,HWANC,HWCOLI,HWALG,
     *                  HWNH2,HWNH3,HWNO2,HWNO3,HWPORG,HWPHOS
     *         /MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,
     *          MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0.,MH*0./
        DATA            DEPHW,DLHW,QATOT,VHW
     *         /MH*0.,MH*0.,MH*0.,MH*0. /
C
C               DECLARE DATA IN THE 'JUNCTS' COMMON.
C
        DATA  D,JUNC  / MJ*0.0,MJ*0,MJ*0,MJ*0 /
C
C               DECLARE DATA IN THE 'REACHS' COMMON.
C
        DATA            DISKO,COEFQV,EXPOQV,COEFQH,EXPOQH,CMANN,
     *                  RCHELV,RCHDAC,RCHCLD,RCHTDB,RCHTWB,
     *                  RCHATM,RCHWND,RCHSAT,RCHSOL
     *         /MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0./
        DATA            CK1,CK3,CK4,CK2,
     *                  COEQK2,EXPQK2,CKNH2,SVNH2,
     *                  CKNH3,SNH3,CKNO2,CKPORG,
     *                  SVPORG,SPHOS,ALPHAO,ALGSET,
     *                  EXCOEF,CK5,CKANC,SETANC,
     *                  SRCANC,TINIT,K2OPT
     *         /MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*50.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0/
        DATA            QI,TI,DOI,BODI,CONSI,
     *                  ANCI,COLIR,ALGI,CNH2I,CNH3I,
     *                  CNO2I,CNO3I,PORGI,PHOSI
     *         /MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0./
        DATA            ALGIT,ANCIT,BOINIT,
     *                  CNH2IT,CNH3IT,CNO2IT,
     *                  CNO3IT,COINIT,COLIIT,
     *                  DOINIT,PHOSIT,PORGIT,
     *                  RMTEOR,RMTHOR,TARGDO,TSONET,
     *                  TSUN,IAUGOR,ICLORD,IFLAG,
     *                  IRCHNO,NCELRH,NHWWAR
     *         /MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,MR*0.,
     *          MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,
     *          MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,
     *          MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,
     *          MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,
     *          MR*0,MR*0,MR*0,MR*0,MR*0,MR*0,MIRCH*0,MR*0,MR*0 /
C
C               DECLARE DATA IN THE 'WASTLD' COMMON.
C
        DATA            TRFACT,WSFLOW,WSTEMP,WSDO,
     *                  WSBOD,WSCONS,WSANC,WSCOLI,
     *                  WSALG,WSNH2,WSNH3,WSNO2,
     *                  WSNO3,WSPORG,WSPHOS
     *        / MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,
     *          MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0.,MW*0. /
C
C +++++
C               Declare data in the 'IOUNIT' COMMON area.
C
C +++++ Modified unit numbers depending on compiler.
C       PC = Ryan-McFarland (RMFORT)
C       SAL= Salford (FTN77/386)
C       SVS= SVS
C       VAX= DEC VAX
C       F7L= Lahey
C
C        DATA CONIN, CONOUT, MSGFIL, CFGFIL, SUPFIL / 5, 7, 9, 10, 11 /
C
CSAL        DATA CONIN, CONOUT, MSGFIL, CFGFIL, SUPFIL / 1, 2, 9, 10, 11 /
CVAX        DATA CONIN, CONOUT, MSGFIL, CFGFIL, SUPFIL / 5, 6, 9, 10, 11 /
CSVS        DATA CONIN, CONOUT, MSGFIL, CFGFIL, SUPFIL / 5, 6, 9, 10, 11 /
        DATA CONIN, CONOUT, MSGFIL, CFGFIL, SUPFIL / 5, 6, 9, 10, 11 /
C
C +++++ Initialization for NJ2 removed.
C       Date: Wednesday, 24 October 1990.  Time: 13:24:42.
C       As per intructions from TOB.
C
C        DATA NI, NJ, NI2, NJ2, NJ4 / 1, 6, 2, 2, 4 /
C        DATA NI, NJ, NI2,       NJ4 / 1, 6, 2,    4 /
C
CSAL        DATA NI, NJ, NI2,       NJ4 / 12, 6, 13,    4 /
CVAX        DATA NI, NJ, NI2, NJ2, NJ4 / 1, 7, 2, 2, 4 /
CVAX        DATA NI, NJ, NI2,      NJ4 / 1, 7, 2,    4 /
CSVS        DATA NI, NJ, NI2,      NJ4 / 1, 7, 2,    4 /
        DATA NI, NJ, NI2,      NJ4 / 1, 7, 2,    4 /
C
C +++++
C
        DATA IM, IU / 1, 1 /
C
C +++++
C
        END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE INIT
C
C     + + + COMMON BLOCKS + + +
C     numeric constants
C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C     + + + LOCAL VARIABLES + + +
      INTEGER          R2PREC,D2PREC,TI
      REAL             R1,R2,R3,R4,  TR
      DOUBLE PRECISION D1,D2,D3,D4
C
C     + + + FUNCTIONS + + +
      REAL             RNOP
      DOUBLE PRECISION DNOP

C     + + + INTRINSICS + + +
      INTRINSIC  INT,LOG10,DBLE
C
C     + + + EQUIVALENCE STATEMENTS + + +
      EQUIVALENCE (TR,TI)
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT(' UNKNOWN DOUBLE PRECISION FORMAT, using default double pre
     .cision values!')
 2010 FORMAT(' UNKNOWN MACHINE TYPE, using default precision values!')
C
C     + + + STATEMENT FUNCTION DEFINITIONS + + +
C     No OPperation, used to keep Ryan/McFarland optimization honest
      RNOP(R1) = R1
      DNOP(D1) = D1
C
C     + + + END SPECIFICATIONS + + +
C
C     Calculate machine dependent numeric constants
C
C     Determine the number of decimal digits of REAL precision number and
C     the smallest REAL greater than 1.0.
C     First find the number of significant binary digits, then convert
C     it to the number of significant decimal digits.  Any machine used
C     today is going to have more than 7 binary digits of precision
C     (actually, we're cheating, because 1 is added to R2PREC after
C     it is tested.  This usually results in 7 decimal digits of
C     precision, which is usually the case, whereas strictly
C     speaking only 6 decimal digits are guaranteed, and 6 is
C     usually the result if R2PREC is initialized to 6).
      R2PREC = 7
      R1 = 1.0
      R2 = 0.0078125
 100  CONTINUE
      R3 = R1 + R2
C     this 'nop' keeps Ryan/McFarland optimization honest.  Without it,
C     the precision of an 80 bit floating point register is computed
C     (instead of a 4-byte real) when R/M optimization is turned on.
C     You can comment out the call to NOP if you observe that by
C     doing so DECCHR doesn't provide extra digits of precision.
      R4 = RNOP(R3)
CDWD
CDWD  Date: Thursday, 7 May 1992.  Time: 10:41:26.
CDWD  Changed .NE. to .LT. as per Salford FORTRAN warning
CDWD  concerning real number comparison with .NE. and .EQ..
CDWD
CDWD      IF (R1 .NE. R3) THEN
      IF (R1 .LT. R3) THEN
         RP1MIN = R3
         R2PREC = R2PREC + 1
         R2 = R2 / 2.0
         GO TO 100
      END IF
C
      RPREC = INT(LOG10(2.0**R2PREC))
C
C     Determine the number of decimal digits of the typical DOUBLE precision
C     number and the smallest DOUBLE greater than 1.0D0.
      D2PREC = 7
      D1 = 1.0D0
      D2 = 0.0078125D0
 200  CONTINUE
      D3 = D1 + D2
C     this 'nop' keeps Ryan/McFarland optimization honest.  Without it,
C     the precision of an 80 bit floating point register is computed
C     (instead of a 4-byte real) when R/M optimization is turned on.
C     You can comment out the call to NOP if you observe that by
C     doing so DECCHR doesn't provide extra digits of precision.
      D4 = DNOP(D3)
CDWD
CDWD  Date: Thursday, 7 May 1992.  Time: 10:41:26.
CDWD  Changed .NE. to .LT. as per Salford FORTRAN warning
CDWD  concerning double precision (real) number comparison with .NE. and .EQ..
CDWD
CDWD      IF (D1 .NE. D3) THEN
      IF (D1 .LT. D3) THEN
         DP1MIN = D3
         D2PREC = D2PREC + 1
         D2 = D2 / 2.0D0
         GO TO 200
      END IF
C
      DPREC = INT(LOG10(2.0D0**D2PREC))
C
      TR = 1.0
      IF (TI .EQ. 1065353216) THEN
C       this should be the case for the Sun or Ryan/McFarland
        R1   = 1.0E-19
C        R0MIN = 1.17549435E-19 * R1
        R0MIN = 1.1754945E-19 * R1
        R1   = 1.0E+19
        R0MAX = 3.40282347E+19 * R1
        D1   = 1.0D-28
        D0MIN = (2.22507385850720219D-28 * D1**10)
        D1   = 1.0D+28
        D0MAX = (1.7976931348623157D0 * D1**11)
      ELSE IF (TI .EQ. 16512) THEN
C       this should be the case for the VAX
        R1   = 1.0E-20
        R0MIN = 2.9387359E-19 * R1
        R1   = 1.0E+18
        R0MAX = 1.7014117E+20 * R1
        IF (DPREC .EQ. 17) THEN
C          this should be the case for the default /NOG_FLOAT compiler option
           D1   = 1.0D-20
           D0MIN = 2.938735877055719D-19 * D1
           D1   = 1.0E+19
           D0MAX = 1.7014118346046923D+19 * D1
        ELSE IF (DPREC .EQ. 16) THEN
C          this should be the case for the /G_FLOAT option
           D3 = 1.0D-21
           D4 = 1.0D-20
           D0MIN = (5.562684646268008D-20)*(D4**5)*(D3**9)
           D3 = 1.0D+21
           D4 = 1.0D+20
           D0MAX = (8.988465674311578D+21) * (D3**6) * (D4**8)
        ELSE
C          assume D_FLOAT real*8 type
           WRITE(*,2000)
           D1   = 1.0D-20
           D0MIN = 2.938735877055719D-19 * D1
           D1   = 1.0E+19
           D0MAX = 1.7014118346046923D+19 * D1
        END IF
      ELSE
        WRITE(*,2010)
        R1    = 1.0E-19
        R0MIN = 1.17549435E-19 * R1
        R1    = 1.0E+18
        R0MAX = 1.7014117E+20 * R1
        D1    = 1.0D-20
        D0MIN = 2.938735877055719D-19 * D1
        D1    = 1.0E+19
        D0MAX = 1.7014118346046923D+19 * D1
      ENDIF
C
CTGC      WRITE(*,*)'EXIT INIT'
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE Q2EZ
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C +++++
C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C +++++
C        INTEGER CONOUT,MSGFIL
C        DATA CONOUT,MSGFIL / 6,9 /
C +++++
CC
CC           Insert the call to HYDRAU and TRIMAT here for
CC            compatability with the flow augmentation option.
CC
CTGC      WRITE(*,*)'ENTER Q2EZ'
      IAGIT = 0
      IF(DISPYN.EQ.'Y') CALL GETMSG(19,MSGFIL)
  998 CALL HYDRAU
CTGC      WRITE(*,*)'IN Q2EZ - LEFT HYDRAU'
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(20,MSGFIL)
CTGC      WRITE(*,*)'IN Q2EZ - CALL TRIMAT'
      CALL TRIMAT
CC
CCC             NCASI Commentary, MAIN - Section G. (QUAL2 Step 7-0)
CCC                     G. Begin computations.
CCC
CCC                     G.1 Initialize iteration counters for
CCC                          steady state simulations.
CCC
      JTER = 0
      ITERN = 0
      ITERO = 0
      NITER=0
      ITER=0
      IPASS = 0
      JPASS = 0
      ITCODE = 1
CCC
CCC                     G.2 Advance time counters for dynamic
CCC                          simulations.
CCC
CC                      ISS=0 is dynamic simulation
CC                      ISS=2 is steady state simulation
C
      IF(ISS.EQ.0) CALL CLRSCR
      IF(ISS.EQ.0) CALL GETMSG(39,MSGFIL)
C
  999 TIME=TIME+D2LT
      TPRINT=TPRINT+D2LT
      IAGIT = IAGIT + 1
CCC
CCC                     G.3 Route water quality constituents
CCC                          according to the value of
CCC                          MODOPT(I). (QUAL2 Step 7-2)
CCC
C                                       MODOPT(1)   CONSERVATIVE
C                                       MODOPT(2)   TEMPERATURE
C                                       MODOPT(3)   BOD
C                                       MODOPT(4)   CHLOROPHYLL A
C                                       MODOPT(5)   PHOSPHOROUS
C                                       MODOPT(6)   NH3,NO2,NO3
C                                       MODOPT(7)   OXYGEN
C                                       MODOPT(8)   COLIFORMS
C                                       MODOPT(9)   NON-CONSERVATIVE
CC
CC           Add the flag IRPT1 to the argument of SOVMAT so that
CC            intermediate output will be printed in the dynamic
CC            simulations, if desired.
CC
C + + + + + + + +
C
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y') CALL CLRSCR
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y')
     1   CALL GETMSG(21,MSGFIL)
CTGC      WRITE(*,*)'IN Q2EZ - CALL TCALCS'
      CALL TCALCS
C
C + + + + + + + +
C
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y') CALL CLRSCR
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y')
     1   CALL GETMSG(22,MSGFIL)
CTGC      WRITE(*,*)'IN Q2EZ - CALL QCALC1'
      CALL QCALC1
C
C + + + + + +
C
C       INSERT CALL TO REAERC FOR COMPUTATIONAL EFFICIENCY
C               (DELETE BELOW IN QCALC2)
C3.0          (ALSO SET UP THE XK2 ARRAY)
C
      IF(MODOPT(7).EQ.0) GO TO 7049
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y') CALL CLRSCR
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y')
     1   CALL GETMSG(23,MSGFIL)
      CALL REAERC
      IJUNC=0
        DO 800 I=1,NREACH
        NCELR = NCELRH(I)
        DO 800 J=1,NCELR
        IOR = ICLORD(I,J)
        IFL = IFLAG(I,J)
        TC = 0.556*(T(IOR)-68.0)
        GO TO (802,804,804,806,804,804,804) IFL
802     XK2(IOR) = K2(IOR)*THETA(3)**TC
        GO TO 800
804     XK2(IOR) = 0.5*(K2(IOR-1)+K2(IOR))*THETA(3)**TC
        GO TO 800
806     IJUNC = IJUNC + 1
        NN=JUNC(IJUNC,1)
        XK2(IOR) = 0.25*(K2(IOR-1)+K2(NN)+2.*K2(IOR))*THETA(3)**TC
800     CONTINUE
7049  CONTINUE
C3.0
C3.0      INITIALIZE ALGAE BIOMASS FF'S
C3.0
      IF(IPASS.NE.0.OR.MODOPT(4).EQ.0) GO TO 7059
      NHW=0
      NWS=0
      DO 7050 I=1,NREACH
      NCELR = NCELRH(I)
      ALGI(I) = ALGI(I)/ALPHAO(I)
      DO 7050 J=1,NCELR
      IFL = IFLAG(I,J)
      IF(IFL.NE.1) GO TO 7051
      NHW = NHW+1
      HWALG(NHW) = HWALG(NHW)/ALPHAO(I)
7051  CONTINUE
      IF(IFL.LT.6) GO TO 7050
      NWS = NWS + 1
      WSALG(NWS) = WSALG(NWS)/ALPHAO(I)
7050  CONTINUE
      ALGLB = ALGLB/ALPHAO(NREACH)
7059  CONTINUE
C3.0
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y') CALL CLRSCR
      IF(ISS.EQ.2.AND.ITER.LE.1.AND.DISPYN.EQ.'Y')
     1   CALL GETMSG(24,MSGFIL)
      CALL QCALC2
C + + + + + + + +
CCC
CCC                     G.14 Test print counter for
CCC                           reinitialization.
CCC
      IF (TPRINT.LT.PTIME) GO TO 997
      JPASS = 0
      TPRINT=0.0
  997 CONTINUE
CCC
CCC                     G.15 Test for steady state modeling.
CCC                           (QUAL2 Step 7-3)
CCC
      IF(ISS.LE.0) GO TO 9996
C
C + + + + + + + +
C
      IF(ITER.LE.1.AND.DISPYN.EQ.'Y') CALL CLRSCR
      IF(ITER.LE.1.AND.DISPYN.EQ.'Y') CALL GETMSG(25,MSGFIL)
      CALL SSCONV
C
C + + + + + + + +
C
      IF(JTER.LE.1) GO TO 7059
      TIME = ITER+ITERN+ITERO
CQ2U
      DO 850 I=1,NCELLS
      SUMN(I)=CNH2(I)+CNH3(I)+CNO2(I)+CNO3(I)
      SUMP(I) = PORG(I)+PHOS(I)
      IF(MODOPT(4).EQ.0) GO TO 850
      APR(I)=(ALPHA3/ALPHA4)*(GROWTH(I)/RESPRR(I))
      APMR(I)=(ALPHA3*GROWTH(I)-ALPHA4*RESPRR(I))*ALGAE(I)
850   CONTINUE
CQ2U
        IF(MODOPT(4).EQ.0) GO TO 2001
CQ2U
C     RESTORE ALGAE TO INPUT FF'S UNITS
C
      NHW=0
      NWS=0
      DO 860 I=1,NREACH
      ALGI(I) = ALGI(I)*ALPHAO(I)
      NCELR = NCELRH(I)
      DO 860 J=1,NCELR
      IFL = IFLAG(I,J)
      IF(IFL.NE.1) GO TO 861
      NHW = NHW+1
      HWALG(NHW) = HWALG(NHW)*ALPHAO(I)
861   CONTINUE
      IF(IFL.LT.6) GO TO 860
      NWS = NWS+1
      WSALG(NWS) = WSALG(NWS)*ALPHAO(I)
860   CONTINUE
      ALGLB = ALGLB*ALPHAO(NREACH)
CQ2U
C
C + + + + + + + +
C
      IF(INTOUT.EQ.2) THEN
        IF(DISPYN.EQ.'Y') CALL CLRSCR
        IF(DISPYN.EQ.'Y') CALL GETMSG(26,MSGFIL)
        CALL WRPT1
      ENDIF
C
C + + + + + + + +
C
      GO TO 2001
 9996 IF (TIME.LT.TMAX) GO TO 999
 2001 CONTINUE
CCC
CCC             NCASI Commentary, MAIN - Section I.
CCC                     I. Test for dynamic/steady mode for writing
CCC                         intermediate report.
CCC
      IF(ISS.LE.0.OR.IRPT1.LE.0) GO TO 9998
C
C + + + + + + + +
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(27,MSGFIL)
      CALL WRPTI
C
C + + + + + + + +
C
        JPASS = 0
 9998 CONTINUE
CCC
CCC             NCASI Commentary, MAIN - Section J. (QUAL2 Step 8-0)
CCC                     J. Test for flow augmentation option.
CCC
      IF (IAUGOP.EQ.0) GO TO 9999
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(28,MSGFIL)
      CALL FLOAUG
C +++++
      IF (ABS(TIME).LT.R0MIN) GO TO 998
C
C      IF (TIME.EQ.0.0) GO TO 998
C +++++
 9999 CONTINUE
CCC
CCC             NCASI Commentary, MAIN - Section K.
CCC                     K. Write final summary.
CCC
      RETURN
C
      END
      SUBROUTINE SOVMAT
C
CCC
CCC             NCASI Commentary, SOVMAT - Section A.
CCC                     A. Subroutine argument.
CC
CC              IRPT1 has been added to the argument of SOVMAT
CC               to pass the flag for printing intermediate
CC               output in the dynamic mode.
CC
C                             SOVMAT SOLVES A SYSTEM OF SIMULTANEOUS
C                             LINEAR EQUATIONS WHOSE COEFFICIENT
C                             MATRIX IS OF TRIDIAGONAL FORM USING
C                             A MODIFIED GAUSSIAN ELIMINATION TYPE OF
C                             ALGORITHM.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
C
      DIMENSION IFLG(MC)
CCC
CCC             NCASI Commentary, SOVMAT - Section B. (QUAL2 Step 1-0)
CCC                     B. Initialize counter.
CCC
      IJUNC=0
CCC
CCC             NCASI Commentary, SOVMAT - Section C. (QUAL2 Step 2-0)
CCC                     C. Set up loop on the number of reaches
CCC                         and elements for Gaussian eleimination.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      IFL=IFLAG(I,J)
      IFLG(IOR)=IFL
      GO TO (101,102,102,103,102,102,102), IFL
CCC
CCC                     C.5 Elimination for Type 1 element.
CCC                          (QUAL2 Step 2-1)
CCC
  101 W(IOR)=C(IOR)/B(IOR)
      G(IOR)=S(IOR)/B(IOR)
      GO TO 100
CCC
CCC                     C.6 Elimination for Type 2, 3, 5, 6, and
CCC                          7 elements. (QUAL2 Step 2-2)
CCC
  102 DENOM=B(IOR)-A(IOR)*W(IOR-1)
      W(IOR)=C(IOR)/DENOM
      G(IOR)=(S(IOR)-A(IOR)*G(IOR-1))/DENOM
      GO TO 100
CCC
CCC                     C.7 Elimination for Type 4 element.
CCC                          (QUAL2 Step 2-3)
CCC
  103 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
      S(IOR)=S(IOR)-D(IJUNC)*G(NN)
      DENOM=B(IOR)-A(IOR)*W(IOR-1)-D(IJUNC)*W(NN)
      W(IOR)=C(IOR)/DENOM
      G(IOR)=(S(IOR)-A(IOR)*G(IOR-1))/DENOM
CCC
CCC                     C.8 Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, SOVMAT - Section D. (QUAL2 Step 3-0)
CCC                     D. Set up loop on IOR for back
CCC                         substitution.
CCC
CCC                     D.1 Solution for last element.
CCC
      Z(IOR)=G(IOR)
      IF (Z(IOR).LT.0.0.AND.NT.NE.15) Z(IOR) = 0.0
  109 IOR=IOR-1
      IFL=IFLG(IOR)
      GO TO (106,106,107,106,106,106,106), IFL
CCC
CCC                     D.4 Solution for Type 1, 2, 4, 5, 6,
CCC                          and 7 elements. (QUAL2 Step 3-1)
CCC
CCC   The following statement may be needed to correct underflow.
CCC
  106 IF (Z(IOR+1).LT.1.0E-35) Z(IOR+1)=0.0
CCC
      Z(IOR)=G(IOR)-W(IOR)*Z(IOR+1)
      IF (Z(IOR).LT.0.0.AND.NT.NE.15) Z(IOR)=0.0
      GO TO 108
CCC
CCC                     D.5 Solution for Type 3 element.
CCC                          (QUAL2 Step 3-2)
CCC
  107 NS=1
      DO 98 IJ=1,NJUNC
      IF (IOR.EQ.JUNC(IJ,NS)) IJUNC=IJ
   98 CONTINUE
      NS=2
      NN=JUNC(IJUNC,NS)
      Z(IOR)=G(IOR)-W(IOR)*Z(NN)
      IF (Z(IOR).LT.0.0.AND.NT.NE.15) Z(IOR)=0.0
  108 CONTINUE
CCC
CCC                     D.6 Test for last element to be solved.
CCC
      IF (IOR.NE.1) GO TO 109
CCC
CCC             NCASI Commentary, SOVMAT - Section E. (QUAL2 Step 4-0)
CCC                     E. Test for intermediate output.
CCC
      IF (TPRINT.LT.PTIME) GO TO 99
      IF(IRPT1.EQ.1)CALL WRPT2 (Z)
   99 CONTINUE
CCC
CCC             NCASI Commentary, SOVMAT - Section F.
CCC                     F. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE WRPT2(CONC)
CCC
CCC             NCASI Commentary, WRPT2 - Section A.
CCC                     A. Subroutine argument.
CCC
C                             WRPT2 WRITES AN INTERMEDIATE SUMMARY
C                             OF THE SELECTED QUALITY CONSTITUENTS.
C                             THESE CONSTITUENTS ARE WRITTEN BY REACH
C                             AND BY ELEMENT.  THIS SUMMARY CAN BE
C                             GIVEN AT A TIME INTERVAL OF DELT OR
C                             SOME MULTIPLE OF DELT.
C
C  UPDATED 6/84 T.WILSON: CORRECTED FORMAT STATEMENTS WHICH
C                         CONTINUED QUOTED STRINGS ACROSS LINES.
C
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

CCC     LEAVE THE COMPRT COMMON COMMENTED OUT. VALUES BEING PASSED IN
CCC     THE CONC ARRAY ARE ARRAYS LOCATED IN THIS COMMON AREA.
CCC     INCLUDE 'COMPRT.VAR'
C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
      DIMENSION P(20),CONC(MC)
      IF(JPASS.EQ.0) WRITE(NJ,5)
5     FORMAT(1H1)
      JPASS = 1
CCC
CCC             NCASI Commentary, WRPT2 - Section B.
CCC                     B. Test for dynamic/steady simulation.
CCC
      IF (ISS) 20,20,10
   10 ITIME=TIME
      WRITE (NJ,15) (TITLE(NT,J),J=6,20),ITIME
   15 FORMAT (1H0,19X,15A4,4X,9HITERATION,I3)
      GO TO 55
   20 CONTINUE
      TINDAY=TIME/24.0
      WRITE (NJ,50) (TITLE(NT,J),J=6,20),TINDAY
   50 FORMAT (1H0,19X,15A4,1X,F5.2,5H DAYS,/)
C                                       STEP 1-0
   55 CONTINUE
CCC
CCC             NCASI Commentary, WRPT2 - Section C.
CCC                     C. Test for coliform printing.
CCC
      IF(NT.EQ.14) GO TO  400
CCC
CCC             NCASI Commentary, WRPT2 - Section D.
CCC                     D. Regular print out format.
CCC
      WRITE(NJ,60)
   60 FORMAT (2X,'RCH/CL  1     2     3     4     5     6     7',
     *'     8     9    10    11    12    13    14    15',
     *'    16    17    18    19',
     *'    20',/)
CCC
CCC                     D.1 Set up loop on the number of reaches
CCC                          and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      DO 200 J=1,NCELR
      IOR=ICLORD(I,J)
      P(J)=CONC(IOR)
CBR
CBR
      IF((NT .EQ. 6).AND.(METOUT.NE.0)) P(J)=(P(J)-32.)/1.8
CBR
CBR
      IF(NT .EQ. 8) P(J)=P(J)*ALPHAO(I)
  200 CONTINUE
CCC
CCC                     D.7 Print out values (intermediate
CCC                          summary). (QUAL2 Step 1-1)
CCC
      WRITE (NJ,300) I,(P(J),J=1,NCELR)
  300 FORMAT (2X,I3,20F6.2)
  100 CONTINUE
CCC
CCC                     D.9 Return to  MAIN or SOVMAT.
CCC
      RETURN
  400 CONTINUE
CCC
CCC             NCASI Commentary, WRPT2 - Section E.
CCC                     E. Special print out for coliform.
CCC
      DO 150 I=1,NREACH
      NCELR=NCELRH(I)
      DO 160 J=1,NCELR
      IOR=ICLORD(I,J)
      P(J)=CONC(IOR)
  160 CONTINUE
      WRITE(NJ,410) I,(P(J),J=1,NCELR)
  410 FORMAT(2X,'RCH/CL     1         2         3         4         5',
     A'         6         7         8         9        10',/,2X,I3,3X,
     B10(1PE10.2),/,2X,'    CL    11        12        13        14',
     C' 15        16        17        18        19        20',/,8X,
     D10(1PE10.2))
  150 CONTINUE
CCC
CCC                     E.5 Return to MAIN or SOVMAT.
CCC
      RETURN
      END
      SUBROUTINE INDATA
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS ALL DATA TYPES FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
      CHARACTER*4       TITL19(15),TITL20(15),TITL21(15),TITL22(15),
     1                  TITL9(15) ,TITL10(15),TITL11(15),TITL12(15)
      DATA TITL9  /'DISS','OLVE','D PH','OSPH','ORUS',' AS ','P IN',
     1             ' MG/','L   ',6*'    '/
      DATA TITL10 /'AMMO','NIA ','AS N',' IN ','MG/L',10*'    '/
      DATA TITL11 /'NITR','ITE ','AS N',' IN ','MG/L',10*'    '/
      DATA TITL12 /'NITR','ATE ','AS N',' IN ','MG/L',10*'    '/
      DATA TITL19 /' ALG','AE G','ROWT','H RA','TES ',
     *             'IN P','ER D','AY A','RE  ',6*'    '/
      DATA TITL20 /' PHO','TOSY','NTHE','SIS-','RESP',
     *             'IRAT','ION ','RATI','OS A','RE  ',5*'    '/
      DATA TITL21 /'ORGA','NIC ','NITR','OGEN',' AS ','N IN',
     1             ' MG/','L   ',7*'    '/
      DATA TITL22 /'ORGA','NIC ','PHOS','PHOR','US A','S P ','IN M',
     1             'G/L ',7*'    '/
CCC
CCC             NCASI Commentary, MAIN - Section A. (QUAL2 Step 1-0)
CCC                     A.  Complete definition of TITLE(I,J) array.
CCC
      DO 10 J=6,20
      I=J-5
      TITLE(19,J)=TITL19(I)
      TITLE(20,J)=TITL20(I)
      TITLE(21,J) = TITL21(I)
      TITLE(22,J) = TITL22(I)
   10 CONTINUE
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(4,9)
      CALL IND00
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(5,9)
      CALL IND01
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(6,9)
      CALL IND1A
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(7,9)
      CALL IND02(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(8,9)
      CALL IND03(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(9,9)
      CALL IND04(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(10,9)
      CALL IND05(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(11,9)
      CALL IND06(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(12,9)
      CALL IND07(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(13,9)
      CALL IND08(II)
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(14,9)
      CALL IND09
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(15,9)
      CALL IND10
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(16,9)
      CALL IND11
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(17,9)
      CALL IND12
C
      IF(DISPYN.EQ.'Y') CALL CLRSCR
      IF(DISPYN.EQ.'Y') CALL GETMSG(18,9)
      CALL IND13
CCC
CQ2E
CQ2E            COMPLETE TITLES
CQ2E
        DO 11 J=6,20
        I = J-5
        TITLE(9,J) = TITL9(I)
        TITLE(10,J) = TITL10(I)
        TITLE(11,J) = TITL11(I)
11      TITLE(12,J) = TITL12(I)
CCC
CCC             NCASI Commentary, MAIN - Section C. (QUAL2 Step 5-0)
CCC                     C. Calculate routing constants.
CCC
      DELX=DELX*5280.0
      IF (ISS) 901,901,900
  900 D1LT = 1.0/24.0
      D2LT = 1.0
      DELT = 3600.0
      IF (PTIME.LE.0.) PTIME=TMAX
      GO TO 902
  901 D1LT = DELT/24.0
      D2LT=DELT
      DELT=DELT*3600.0
      TMAX=TMAX-0.01
  902 CONTINUE
      DTODX2=DELT/(DELX*DELX)
      DT2ODX=2.0*DELT/DELX
CCC
CCC             NCASI Commentary, MAIN - Section F. (QUAL2 Step 6-0)
CCC                     F. Set initial conditions for all
CCC                         computational elements.
CCC
      DO 915 I=1,NREACH
      NCELR=NCELRH(I)
      DO 915 J=1,NCELR
      IOR=ICLORD(I,J)
      T(IOR)=TINIT(I)
      DO2(IOR)=DOINIT(I)
      BOD(IOR)=BOINIT(I)
      CONS(IOR,1)=COINIT(I,1)
      CONS(IOR,2)=COINIT(I,2)
      CONS(IOR,3)=COINIT(I,3)
      ALGAE(IOR)=ALGIT(I)/ALPHAO(I)
      PORG(IOR) = PORGIT(I)
      PHOS(IOR)=PHOSIT(I)
      CNH2(IOR) = CNH2IT(I)
      CNH3(IOR)=CNH3IT(I)
      CNO2(IOR)=CNO2IT(I)
      CNO3(IOR)=CNO3IT(I)
      COLI(IOR)=COLIIT(I)
      ANC(IOR)=ANCIT(I)
  915 CONTINUE
      DO 922 NWS=1,NWASTE
      EFLBOD=1.0-TRFACT(NWS)
      WSBOD(NWS)=EFLBOD*WSBOD(NWS)
  922 CONTINUE
CQ2E
      IF (NERROR.EQ.0) GO TO 888
      WRITE (NJ,2066)
 2066 FORMAT (1H1,15X,34H* * * * * * * * * * * * * * * * * ,
     *                33H* * * * * * * * * * * * * * * * *,//,
     *            16X,34H* E X E C U T I O N   W A S   T E ,
     *                33HR M I N A T E D   B E C A U S E *,//,
     *            16X, 1H*,31X,3HO F,31X,1H*,//,
     *            16X,34H*             E R R O R S   I N   ,
     *                33HI N P U T   D A T A             *,//,
     *            16X,34H* * * * * * * * * * * * * * * * * ,
     *                33H* * * * * * * * * * * * * * * * *)
      STOP
CCC
  888 RETURN
      END
      SUBROUTINE IND00
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 00  FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
      CHARACTER*4       ENDT,YES
      DATA ENDT/'ENDT'/ , YES/' YES'/
C      CHARACTER*4       ENDT,ENDA,YES
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section B. (QUAL2 Step 1-0)
CCC                     B. Initialize certain control variables,
CCC                         parameters, etc.
CCC
       DO 999 I=1,MC
       ALGAE(I)=0.
       RESPRR(I)=0.
       GROWTH(I)=0.
       JDAM(I) = 0
  999 CONTINUE
CC
CC              Change DO loop limit to MIRCH to agree with
CC                      dimensioned size of array.
CC
      DO 1000 I=1,MIRCH
 1000 IRCHNO(I)=0
CC
CC              Initialize CK2 array to avoid output errors.
CC
CC   ->-> CHANGED DO PARAMETER FROM 500 TO MR <-<-
CC   ->-> TO MATCH DIMENSION OF CK2 ARRAY. (T.WILSON 6/15/84)
CC
C    -> -> NOTE DO PARAMETERS CHANGED ABOVE (VARIABLES)  <-  <-
C
        DO 3921 I=1,MR
3921    CK2(I) = 0.0
CC
      ITEMP = 0
      IPLOT = 0
      ITRAP=0
      ILIST=0
      IRPT1=0
      IAUGOP =0
      ISS=0
      LAT=0.0
      LLM=0.0
      LSM=0.0
      DAYOFY=0.0
      AE=0.0
      BE=0.0
      ELEV=0.0
      DAT=0.0
      NERROR=0
      TIME=0.0
      TPRINT=0.0
      TOFDAY=0.0
      TRLCD=0.0
      CKL=0.0
      METRIC=0
      METOUT=0
      LBFLG=0
CCC
CCC             NCASI Commentary, INDATA - Section C.
CCC                     C. Read input and output data file
CCC                         information.
CCC
CCC
CCC             NCASI Commentary, INDATA - Section D. (QUAL2 Step 2-0)
CCC                     D. Read in titles.
CCC
      DO 30 I=1,16
      READ (NI,31) (TITLE(I,J),J=1,20)
   31 FORMAT (20A4)
C//   IF (TITLE(I,1)-ENDT) 30,35,30
      IF (TITLE(I,1) .EQ. ENDT) GO TO 35
   30 CONTINUE
      NERROR=1
   34 I=I+1
      READ (NI,31) (TITLE(I,J),J=1,20)
C//   IF (TITLE(I,1)-ENDT)34,39,34
      IF (TITLE(I,1) .NE. ENDT) GO TO 34
C +++++
C   39 N=I-16
      N=I-16
C +++++
      WRITE (NJ,32) N
   32 FORMAT (1HO,5X,16H***** TOO MANY (,I3,18H) TITLE CARDS READ)
      GO TO 33
   35 IF (I.GE.16) GO TO 33
      NERROR=1
      N=16-I
      WRITE (NJ,36) N
   36 FORMAT (1HO,5X,15H***** TOO FEW (,I3,18H) TITLE CARDS READ)
   33 CONTINUE
      NTITLE=I
CCC
CCC                     D.3 Define model option array.
CCC                          (QUAL2 Step 2-1)
CCC
      DO 1700 I=1,9
 1700 MODOPT(I)=0
      IF(TITLE(3,3) .EQ. YES) MODOPT(1)=1
      DO 1710 I=6,9
      IF(TITLE(I,3) .EQ. YES) MODOPT(I-4)=1
 1710 CONTINUE
      IF(TITLE(11,3) .EQ. YES) MODOPT(6)=1
      DO 1720 I=13,15
      IF(TITLE(I,3) .EQ. YES) MODOPT(I-6)=1
 1720 CONTINUE
CCC
CCC                     D.5 Determine the number of conservative
CCC                          minerals to be simulated (NCS).
CCC                           (QUAL2 Step 2-2)
CCC
      NCS=0
      IF(MODOPT(1) .LT. 1) GO TO 1730
      NCS=1
      IF(TITLE(4,3) .EQ. YES) NCS=2
      IF(TITLE(5,3) .EQ. YES) NCS=3
 1730 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND01
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 01 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C       INCLUDE 'COMPRT.VAR'
C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C       INCLUDE 'REACHS.VAR'
C       INCLUDE 'WASTLD.VAR'
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C
C +++++
C      CHARACTER*4       CODE(17),ADATA(ML,14),ENDT,ENDA,YES
      CHARACTER*4       CODE(17),ADATA(ML,14),ENDA
C +++++
      DIMENSION         RDATA(ML,2)
CC ->-> DECLARE VARIABLE 'DFLT' INTEGER - T.WILSON 6.15.84 <-<-
C//   INTEGER*4 DFLT,DEFLT,USERR
C//   DATA DEFLT,USERR/4HDFLT,4HUSER/
C//   DIMENSION CODET(2,19),DFLT(19)
C
C +++++
      DATA ENDA/'ENDA'/
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
C +++++
      DATA CODE/'LIST','WRIT','FLOW','STEA','TRAP','PRIN','PLOT',
     *   'FIXE','INPU','NUMB','NUM ','TIME','MAXI','LATI','STAN',
     *   'EVAP','ELEV'/
CCC
CCC                     D.6 Determine value of the parameter, IDATA.
CCC                          (QUAL2 Step 3-0)
CCC
      IDATA1=0
      IDATA=0
      IF(MODOPT(4) .GT. 0) IDATA=1
      IF(MODOPT(5) .GT. 0) IDATA=1
      IF(MODOPT(6) .GT. 0) IDATA=1
      IF(MODOPT(8) .GT. 0) IDATA1=1
      IF(MODOPT(9) .GT. 0) IDATA1=1
CCC
CCC             NCASI Commentary, INDATA - Section E. (QUAL2 Step 3-1)
CCC                     E. Read in Type 1 data. (Model Control
CCC                         (Information)
CCC
      NCRDS=18
      DO 20 I=1,NCRDS
      READ (NI,21) (ADATA(I,K),K=1,7), RDATA(I,1),
     *             (ADATA(I,K),K=8,14),RDATA(I,2)
   21 FORMAT (6A4,A1,F10.0,10X,6A4,A1,F10.0)
C//   IF (DATA(I,1)-ENDA)20,25,20
      IF (ADATA(I,1) .EQ. ENDA) GO TO 25
   20 CONTINUE
      NERROR=1
   24 I=I+1
      READ (NI,21) (ADATA(I,K),K=1,7), RDATA(I,1),
     *             (ADATA(I,K),K=8,14),RDATA(I,2)
C//   IF (DATA(I,1)-ENDA)24,29,24
      IF (ADATA(I,1) .NE. ENDA) GO TO 24
C +++++
C   29 N=I-NCRDS
      N=I-NCRDS
C +++++
      WRITE (NJ,22) N
   22 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA1 CARDS READ)
      GO TO 23
   25 IF (I.GE.NCRDS) GO TO 23
      IF(MODOPT(2)) 1920,1920,1930
CC
CC              Change 10 to 14 in the next statement to correct
CC               the logic error.
CC
 1920 IF(I .EQ. 14) GO TO 23
 1930 NERROR=1
      N=NCRDS-I
      WRITE (NJ,26) N
   26 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA1 CARDS READ)
   23 CONTINUE
      NCRDS=I
      N=I-1
CCC
CCC                     E.5  Set up loop to compare DATA(I,1) with
CCC                          CODE(J) to set or define the model
CCC                          control parameters.
CCC
      DO 16 I=1,N
      DO 16 J=1,17
C//   IF (DATA(I,1)-CODE(J)) 16,2,16
      IF (ADATA(I,1) .NE. CODE(J)) GO TO 16
C +++++
C    2 GO TO (3,4,5,6,7,19,191,192,8,9,10,11,12,13,14,15,18),J
      GO TO (3,4,5,6,7,19,191,192,8,9,10,11,12,13,14,15,18),J
C +++++
    3 ILIST = 1
      GO TO 16
    4 IRPT1=1
      GO TO 16
    5 IAUGOP = 1
      GO TO 16
    6 ISS = 2
      GO TO 16
    7 ITRAP=1
      GO TO 16
19    ITEMP = 1
      GO TO 16
191   IPLOT = 1
      GO TO 16
192   LBF = RDATA(I,1)
      IF(LBF.GE.1) LBFLG=1
      KBOD=.23
C +++++
C      IF(RDATA(I,2).NE.0) KBOD=RDATA(I,2)
      TVAL=RDATA(I,2)
      IF(ABS(TVAL).GT.R0MIN) KBOD=RDATA(I,2)
C +++++
      RDATA(I,2) = KBOD
      GO TO 16
8     IMI = RDATA(I,1)
      IMO = RDATA(I,2)
      IF(IMI.GE.1) METRIC = 1
      IF(IMO.GE.1) METOUT = 1
      GO TO 16
    9 NREACH = RDATA(I,1)
      NJUNC = RDATA(I,2)
      GO TO 16
   10 NHWTRS = RDATA(I,1)
      NWASTE = RDATA(I,2)
      GO TO 16
   11 DELT = RDATA(I,1)
      DELX = RDATA(I,2)
      GO TO 16
   12 TMAX = RDATA(I,1)
      PTIME = RDATA(I,2)
      GO TO 16
   13 LAT = RDATA(I,1)
      LLM = RDATA(I,2)
      GO TO 16
   14 LSM = RDATA(I,1)
      DAYOFY = RDATA(I,2)
      GO TO 16
   15 AE = RDATA(I,1)
      BE = RDATA(I,2)
      GO TO 16
   18 ELEV=RDATA(I,1)
      DAT=RDATA(I,2)
   16 CONTINUE
CQ2E + + + + + + +
C
C       CHANGE DIMENSION LIMITS TO THOSE IN PARAMETER STATEMENTS
C                               AND
C       ADD TESTS ON MAX NUMBER OF JUNCTIONS AND HEADWATERS.
C
      IF(NREACH-MR) 610,610,620
  620 WRITE(NJ,515)  NREACH,MR
  515 FORMAT (1H0,5X,'*****',I5,'REACHES EXCEED THE DIMENSIONS',
     *        ' OF',I5)
      NERROR=1
  610 CONTINUE
      IF(NWASTE-MW) 630,630,640
  640 WRITE(NJ,516)  NWASTE,MW
  516 FORMAT(1H0,5X,'*****',I5,'WASTE LOADS EXCEED THE PROGRAM'
     *,     ' DIMENSIONS OF',I5)
      NERROR=1
630   CONTINUE
C
      IF(NJUNC-MJ) 650,650,660
660   WRITE (NJ,517) NJUNC,MJ
517   FORMAT (1H0,5X,'*****',I5,'JUNCTIONS EXCEED THE PROGRAM',
     *        ' DIMENSIONS OF',I5)
      NERROR=1
650   CONTINUE
      IF(NHWTRS-MH) 670,670,680
680   WRITE(NJ,518) NHWTRS,MH
518   FORMAT(1H0,5X,'*****',I5,'HEADWATERS EXCEED THE PROGRAM',
     * ' DIMENSIONS OF',I5)
      NERROR=1
670   CONTINUE
CQ2E
C + + + + + +
CQ2E
      IF (ILIST.EQ.0) GO TO 200
      WRITE (NJ,501)VERNUM
501   FORMAT(1H1,46X,'* * * QUAL-2E ',
     * 35H STREAM QUALITY ROUTING MODEL * * *,/,60X,A26)
C     * '* * * EPA/NCASI VERSION * * *'/)
      WRITE (NJ,502)
  502 FORMAT (1H0,10X,24H$$$ (PROBLEM TITLES) $$$,/)
      WRITE (NJ,201)
  201 FORMAT (10X,9HCARD TYPE,29X,22HQUAL-2E PROGRAM TITLES)
      WRITE (NJ,503) ((TITLE(I,J),J=1,20),I=1,NTITLE)
  503 FORMAT (10X,20A4)
      WRITE (NJ,504)
  504 FORMAT (1H0,10X,34H$$$ DATA TYPE 1 (CONTROL DATA) $$$,/)
      WRITE (NJ,203)
  203 FORMAT (10X,9HCARD TYPE,36X,9HCARD TYPE)
      DO 208 I = 1, NCRDS
      WRITE (NJ,103) (ADATA(I,J),J=1,7) ,RDATA(I,1),
     *               (ADATA(I,J),J=8,14),RDATA(I,2)
  208 CONTINUE
  103 FORMAT (2(10X,6A4,A1,F10.5))
  200 CONTINUE
      IF(METRIC.EQ.0) GO TO 199
      DELX=DELX/1.609
      IF(MODOPT(2).EQ.0) GO TO 199
      AE=3.2808*AE*(1000./29.9)
      BE=3.2808*BE*(1000./29.9)*(1609./3600.)
      ELEV=3.2808*ELEV
  199 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND1A
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 01 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C       INCLUDE 'CHARCT.VAR'
C       INCLUDE 'COMPRT.VAR'
C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C       INCLUDE 'REACHS.VAR'
C       INCLUDE 'WASTLD.VAR'
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C
C +++++
C      CHARACTER*4       CODE2(11),CODET(2,19),DEFLT,USERR,ENDT,ENDA,
C     *                  YES,DFLT(19),ADATA(ML,16)
      CHARACTER*4       CODE2(11),CODET(2,19),DEFLT,USERR,ENDA,
     *                  DFLT(19),ADATA(ML,16)
      DIMENSION         RDATA(ML,2)
CC ->-> DECLARE VARIABLE 'DFLT' INTEGER - T.WILSON 6.15.84 <-<-
C
      DATA DEFLT,USERR /'DFLT','USER'/
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
      DATA CODE2/'O UP','O PR','N CO','ALG ','N HA','LIN ',
     1           'LIGH','DAIL','NUMB','ALGY','ALG/'/
      DATA CODET/'BOD ','DECA','BOD ','SETT','OXY ','TRAN','SOD ',
     1    'RATE','ORGN',' DEC','ORGN',' SET','NH3 ','DECA','NH3 ',
     2    'SRCE','NO2 ','DECA','PORG',' DEC','PORG',' SET','DISP',
     3    ' SRC','ALG ','GROW','ALG ','RESP','ALG ','SETT',
     4    'COLI',' DEC','ANC ','DECA','ANC ','SETT','ANC ','SRCE'/
CCC
CCC             NCASI Commentary, INDATA - Section F. (QUAL2 Step 3-1A)
CCC                     F. Read in Type 1A data. (Algae,N,P
CCC                         constants)
CCC
      DO 1003 I=1,12
      READ (NI,1001) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
 1001 FORMAT (8A4,F7.0,2X,8A4,F7.0)
C//   IF (DATA(I,1)-ENDA) 1003,1021,1003
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1021
 1003 CONTINUE
      NERROR=1
 1005 I=I+1
      READ (NI,1001) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
C//   IF (DATA(I,1)-ENDA) 1005,1007,1005
      IF (ADATA(I,1) .NE. ENDA) GO TO 1005
C +++++
C 1007 N=I-12
      N=I-12
C +++++
      WRITE (NJ,1020) N
 1020 FORMAT (1H0,5X,16H***** TOO MANY (,I3,20H) DATA 1A CARDS READ)
      GO TO 1004
 1021 IF (I.GE.12) GO TO 1004
      IF(IDATA) 1024,1024,1025
 1024 NCRDS=1
      GO TO 1026
 1025 NERROR=1
      N=12-I
      WRITE (NJ,1022) N
 1022 FORMAT (1H0,5X,15H***** TOO FEW (,I3,20H) DATA 1A CARDS READ)
 1004 CONTINUE
      N=I-1
      NCRDS=I
CCC
CCC                     F.4 Set up loop to compare DATA(I,1) WITH
CCC                          CODE2(J) to define the algae, N, and P
CCC                          constants.
CCC
      DO 1006 I=1,N
      DO 1006 J=1,11
C//   IF(DATA(I,1)-CODE2(J))1006,1008,1006
      IF (ADATA(I,1) .NE. CODE2(J)) GO TO 1006
C +++++
C 1008 GO TO (1009,1010,1011,1012,1013,1030,1031,1032,1033,1034,1035),J
      GO TO (1009,1010,1011,1012,1013,1030,1031,1032,1033,1034,1035),J
C +++++
 1009 ALPHA5=RDATA(I,1)
      ALPHA6=RDATA(I,2)
      GO TO 1006
 1010 ALPHA3=RDATA(I,1)
      ALPHA4=RDATA(I,2)
      GO TO 1006
 1011 ALPHA1=RDATA(I,1)
      ALPHA2=RDATA(I,2)
      GO TO 1006
 1012 GROMAX=RDATA(I,1)
      RESPRT=RDATA(I,2)
      GO TO 1006
 1013 CKN=RDATA(I,1)
      CKP=RDATA(I,2)
      GO TO 1006
1030  EXALG1 = RDATA(I,1)
      EXALG2 = RDATA(I,2)
      GO TO 1006
1031  LFNOPT = RDATA(I,1)
      CKL = RDATA(I,2)
      CKL = CKL*60.0
      GO TO 1006
1032  LAVOPT = RDATA(I,1)
      AFACT = RDATA(I,2)
      GO TO 1006
1033  DLH = RDATA(I,1)
      NDLH = DLH
      SONET = RDATA(I,2)
      GO TO 1006
1034  LGROPT = RDATA(I,1)
      PREFN = RDATA(I,2)
      GO TO 1006
1035  TFACT = RDATA(I,1)
      KNITRF = 10.0
C +++++
C      IF(RDATA(I,2).NE.0.0) KNITRF = RDATA(I,2)
      TVAL=RDATA(I,2)
      IF(ABS(TVAL).GT.R0MIN) KNITRF = RDATA(I,2)
C +++++
      RDATA(I,2)=KNITRF
1006  CONTINUE
CQ2E
      IF(METRIC.EQ.0) GO TO 1026
      EXALG1 = EXALG1/3.2808
      EXALG2 = EXALG2/3.2808
      CKL = CKL*3.685
      SONET = SONET*3.685
CQ2E
 1026 IF (ILIST .EQ. 0) GO TO 1015
      WRITE (NJ,1016)
 1016 FORMAT (1H0,10X,'$$$ DATA TYPE 1A (ALGAE PRODUCTION AND NITROGEN',
     *' OXIDATION CONSTANTS) $$$',/)
      WRITE (NJ,1017)
 1017 FORMAT (10X,9HCARD TYPE,43X,9HCARD TYPE)
CQ2E
      IF(IDATA.EQ.0) GO TO 2050
      DO 2010 I=1,5
2010  WRITE(NJ,1018) (ADATA(I,J),J=1,8),  RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
      IF(METRIC.EQ.1) GO TO 3020
      I=6
      WRITE(NJ,2021) RDATA(I,1),RDATA(I,2)
2021  FORMAT(10X,'LIN ALG SHADE CO (1/FT-UGCHA/L=)',F10.4,
     * 10X,'NLIN SHADE(1/FT-(UGCHA/L)**2/3)=',F10.4)
      I=7
      WRITE(NJ,2022) (ADATA(I,J),J=1,8),(RDATA(I,J),J=1,2)
2022  FORMAT(10X,8A4,F10.4,10X,'LIGHT ',5HSAT'N,' COEF (BTU/FT2',
     * '-MIN) =',F10.4)
      I=8
      WRITE(NJ,1018) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
      I=9
      WRITE(NJ,2023) (ADATA(I,J),J=1,8),(RDATA(I,J),J=1,2)
2023  FORMAT(10X,8A4,F10.4,10X,'TOTAL DAILY SOLR RAD (BTU/FT-2)=',
     * F10.4)
      GO TO 2030
3020  CONTINUE
      I=6
      WRITE(NJ,3021) RDATA(I,1),RDATA(I,2)
3021  FORMAT(10X,'LIN ALG SHADE CO (1/M-UGCHA/L) =',F10.4,
     * 10X,'NLIN SHADE (1/M-(UGCHA/L)**2/3)=',F10.4)
      I=7
      WRITE(NJ,3022) (ADATA(I,J),J=1,8),(RDATA(I,J),J=1,2)
3022  FORMAT(10X,8A4,F10.4,10X,'LIGHT ',5HSAT'N,' COEF (LANGLEYS/',
     * 'MIN)=',F10.4)
      I=8
      WRITE(NJ,1018) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
      I=9
      WRITE(NJ,3023) (ADATA(I,J),J=1,8),(RDATA(I,J),J=1,2)
3023  FORMAT(10X,8A4,F10.4,10X,'TOTAL DAILY SOLR RAD (LANGLEYS)=',
     * F10.4)
2030  CONTINUE
      DO 2040 I=10,11
2040  WRITE(NJ,1018) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
2050  I=NCRDS
      WRITE(NJ,1018) (ADATA(I,J),J=1,8), RDATA(I,1),
     *               (ADATA(I,J),J=9,16),RDATA(I,2)
 1018 FORMAT(2(10X,8A4,F10.4))
 1015 CONTINUE
      IF(MODOPT(4).EQ.0) GO TO 197
      IF(MODOPT(2).EQ.0.AND.LAVOPT.EQ.1) GO TO 198
      IF(MODOPT(2).EQ.0.AND.LAVOPT.EQ.3) GO TO 198
      GO TO 197
198   CONTINUE
      NERROR=1
      WRITE(NJ,196) LAVOPT
196   FORMAT(/5X,'****ERROR-TEMPERATURE IS NOT SIMULATED, THUS THE'/
     110X,'VALUE OF LAVOPT MUST BE 2 OR 4; NOT',I4,' AS INPUT****'/)
197   CONTINUE
CQ2E
CQ2E            TYPE 1B DATA
CQ2E
        THETA(1) = 1.047
        THETA(2) = 1.024
        THETA(3) = 1.024
        THETA(4) = 1.060
        THETA(5) = 1.047
        THETA(6) = 1.024
        THETA(7) = 1.083
        THETA(8) = 1.074
        THETA(9) = 1.047
        THETA(10) = 1.047
        THETA(11) = 1.024
        THETA(12) = 1.074
        THETA(13) = 1.047
        THETA(14) = 1.047
        THETA(15) = 1.024
        THETA(16) = 1.047
        THETA(17) = 1.000
        THETA(18) = 1.024
        THETA(19) = 1.000
        DO 301 I=1,19
CC ->-> CHANGE QUOTED STRINGS TO VBL ASGNMNTS OF "DFLT" TWILSON 6/15/84
301     DFLT(I) = DEFLT
        DO 300 I=1,19
        READ(NI,305) (ADATA(I,J),J=1,4),RDATA(I,1)
305     FORMAT(2A4,1X,2A4,1X,F8.0)
        IF (ADATA(I,1) .EQ. ENDA) GO TO 310
300     CONTINUE
310     ICRDS = I-1
        KCRDS = I
        IF(ICRDS.EQ.0) GO TO 330
        DO 320 I=1,ICRDS
        DO 315 J=1,19
        IF (ADATA(I,3).NE.CODET(1,J)) GO TO 315
        IF (ADATA(I,4).NE.CODET(2,J)) GO TO 315
        GO TO 325
315     CONTINUE
        NERROR = NERROR + 1
        WRITE(NJ,317) ADATA(I,3),ADATA(I,4)
317     FORMAT(/' ***** ',2A4,' IS NOT A RECOGNIZABLE PARAMETER',
     1 ' CODE FOR THETA'/)
        GO TO 320
325     CONTINUE
        THETA(J) = RDATA(I,1)
        DFLT(J) = USERR
320     CONTINUE
330     CONTINUE
        IF(ILIST.EQ.0) GO TO 340
        WRITE(NJ,332)
332     FORMAT(1H0,10X,'$$$ DATA TYPE 1B (TEMPERATURE CORRECTION',
     1 ' CONSTANTS FOR RATE COEFFICIENTS) $$$'//10X,'CARD TYPE',
     2 5X,'RATE CODE',5X,'THETA VALUE',5X/)
C3.0    IF(ICRDS.LE.0) GO TO 340
        DO 335 I=1,19
335     WRITE(NJ,336) I,(CODET(J,I),J=1,2),THETA(I),DFLT(I)
336     FORMAT(10X,'THETA(',I2,')',6X,2A4,5X,F8.3,5X,A4)
        WRITE(NJ,338) (ADATA(KCRDS,J),J=1,2)
338     FORMAT(10X,2A4)
340     CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND02(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 02 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C
C +++++
C      CHARACTER*4       ADATA(ML,10),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,10),ENDA
C +++++
      DIMENSION         RDATA(ML,3)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section G. (QUAL2 Step 3-2)
CCC                     G. Read in Type 2 data. (Reach ID and
CCC                          River Miles)
CCC
      II = NREACH+1
      DO 50 I=1,II
      READ (NI,51) (ADATA(I,J),J=1,3),RDATA(I,1),(ADATA(I,J),J=4,9),
     *             RDATA(I,2),ADATA(I,10),RDATA(I,3)
   51 FORMAT (3A4,3X,F5.0,5A4,3X,A4,3X,F10.0,4X,A2,4X,F10.0)
C//   IF (DATA(I,1)-ENDA) 50,55,50
      IF (ADATA(I,1) .EQ. ENDA) GO TO 55
   50 CONTINUE
      NERROR=1
   54 I=I+1
      READ (NI,51) (ADATA(I,J),J=1,3),RDATA(I,1),(ADATA(I,J),J=4,9),
     *             RDATA(I,2),ADATA(I,10),RDATA(I,3)
C//   IF (DATA(I,1)-ENDA) 54,59,54
      IF (ADATA(I,1) .NE. ENDA) GO TO 54
C +++++
C   59 N=I-II
      N=I-II
C +++++
      WRITE (NJ,52) N
   52 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA2 CARDS READ)
      GO TO 53
   55 IF (I.GE.II) GO TO 53
      NERROR = 1
      N=II-I
      WRITE (NJ,56) N
   56 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA2 CARDS READ)
   53 CONTINUE
      NCRDS=I
CCC
CCC                     G.5 Set up loop to multiply reach id by 10,
CCC                          make it an integer, and flag an array,
CCC                          IRCHNO, at indexes corresponding to
CCC                          the expanded reach id.
CCC
      IMAX=0
      DO 1050 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      IRCHNO(IRCH)=1
      IMAX=MAX0(IMAX,IRCH)
 1050 CONTINUE
      IORDER=0
      DO 1055 IRCH=1,IMAX
      IF (IRCHNO(IRCH)) 1055,1055,1052
 1052 IORDER=IORDER+1
      IRCHNO(IRCH)=IORDER
 1055 CONTINUE
CCC
CCC                     G.6 Set up loop on IRCHNO so that flagged
CCC                          values are ordered as consecutive
CCC                          values.
CCC
      DO 57 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
C//   DO 58 J=5,9
C//   K = J-4
C//   RCHID(NRCH,K) = DATA(I,J)
      DO 58 J = 4, 8
      K = J - 3
      RCHID(NRCH,K) = ADATA(I,J)
   58 CONTINUE
      RMTHOR(NRCH) = RDATA(I,2)
      RMTEOR(NRCH) = RDATA(I,3)
      IF(METRIC.NE.1)GO TO 57
      RMTHOR(NRCH)=RMTHOR(NRCH)/1.609
      RMTEOR(NRCH)=RMTEOR(NRCH)/1.609
   57 CONTINUE
      IF (ILIST.EQ.0) GO TO 425
      WRITE (NJ,505)
  505 FORMAT (1H0,10X,42H$$$ DATA TYPE 2 (REACH IDENTIFICATION) $$$,/)
      WRITE (NJ,205)
  205 FORMAT (10X,9HCARD TYPE,11X,'REACH ORDER AND IDENT',
     *        15X,'R. MI/KM',12X,'R. MI/KM')
      DO 208 I = 1, NCRDS
      WRITE (NJ,401) (ADATA(I,J),J=1,3),RDATA(I,1),(ADATA(I,J),J=4,9),
     *               RDATA(I,2),ADATA(I,10),RDATA(I,3)
  208 CONTINUE
  401 FORMAT (10X,3A4,3X,F5.1,2X,5A4,3X,A4,3X,F10.1,4X,A2,4X,F10.1)
  425 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND03(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 03 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C
C +++++
C      CHARACTER*4       ADATA(ML,5),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,5),ENDA
C +++++
      DIMENSION         RDATA(ML,9)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section H. (QUAL2 Step 3-3)
CCC                     H. Read in Type 3 data. (Target DO and
CCC                         Flow Augmentation)
CCC
      DO 60 I=1,II
      READ (NI,61) (ADATA(I,J),J=1,5),(RDATA(I,J),J=1,9)
   61 FORMAT (5A4,5X,F5.0,5X,F5.0,F10.0,6F5.0)
C//   IF (DATA(I,1)-ENDA) 60,65,60
      IF (ADATA(I,1) .EQ. ENDA) GO TO 65
   60 CONTINUE
      NERROR = 1
   64 I=I+1
      READ (NI,61) (ADATA(I,J),J=1,5),(RDATA(I,J),J=1,9)
C//   IF (DATA(I,1)-ENDA) 64,69,64
      IF (ADATA(I,1) .NE. ENDA) GO TO 64
C +++++
C   69 N=I-II
      N=I-II
C +++++
      WRITE (NJ,62) N
   62 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA3 CARDS READ)
      GO TO 63
   65 IF (I.GE.II) GO TO 63
      IF(IAUGOP) 8623,8623,8624
 8623 NCRDS=1
      GO TO 8625
 8624 NERROR=1
      N=II-I
      WRITE (NJ,66) N
   66 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA3 CARDS READ)
   63 CONTINUE
      NCRDS=I
      DO 67 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      NHWAR = RDATA(I,2)
      NHWWAR(NRCH) = NHWAR
      TARGDO(NRCH)= RDATA(I,3)
C//   DO 68 J=9,14
C//   K = J-8
      DO 68 J = 4, 9
      K = J - 3
      IAUGOR(NRCH,K) = RDATA(I,J)
   68 CONTINUE
   67 CONTINUE
 8625 IF (ILIST.EQ.0) GO TO 426
      WRITE (NJ,506)
  506 FORMAT (1H0,10X,36H$$$ DATA TYPE 3 (TARGET LEVEL DO AND,
     *                31H FLOW AUGMENTATION SOURCES) $$$,/)
      WRITE (NJ,206)
  206 FORMAT (10X,9HCARD TYPE,18X,24HREACH  AVAIL HDWS TARGET,
     *         5X,22HORDER OF AVAIL SOURCES)
      DO 208 I = 1, NCRDS
      WRITE (NJ,402) (ADATA(I,J),J=1,5),(RDATA(I,J),J=1,9)
  208 CONTINUE
  402 FORMAT (10X,5A4,5X,F5.0,5X,F5.0,F10.1,6F5.0)
  426 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND04(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 04 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C
C +++++
C      CHARACTER*4       ADATA(ML,3),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,3),ENDA
C +++++
      DIMENSION         RDATA(ML,22)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section I. (QUAL2 Step 3-4)
CCC                     I. Read in Type 4 data. (Computational
CCC                          Element Flag Field)
CCC
C                                           1  =  ELEMENT WHICH REPRESEN
C                                                 HEADWATER SOURCE.
C                                           2  =  AN ELEMENT WITH NO EXT
C                                                 INPUTS OTHER THAN INCR
C                                           3  =  AN ELEMENT ON THE MAIN
C                                                 IMMEDIATELY UPSTREAM F
C                                                 JUNCTION.
C                                           4  =  AN ELEMENT WHICH REPRE
C                                                 A STREAM JUNCTION.
C                                           5  =  AN ELEMENT WHICH REPRE
C                                                 THE LAST COMPUTATIONAL
C                                                 IN THE SYSTEM.
C                                           6  =  AN ELEMENT WITH A WAST
C                                           7  =  AN ELEMENT WITH A WITH
C
      DO 70 I=1,II
      READ (NI,71) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,22)
   71 FORMAT (2A4,A2,5X,F5.0,5X,F5.0,10X,20F2.0)
C//   IF (DATA(I,1)-ENDA) 70,75,70
      IF (ADATA(I,1) .EQ. ENDA) GO TO 75
   70 CONTINUE
      NERROR=1
   74 I=I+1
      READ (NI,71) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,22)
C//   IF (DATA(I,1)-ENDA) 74,79,74
      IF (ADATA(I,1) .NE. ENDA) GO TO 74
C +++++
C   79 N=I-II
      N=I-II
C +++++
      WRITE (NJ,72) N
   72 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA4 CARDS READ)
      GO TO 73
   75 IF (I.GE.II) GO TO 73
      NERROR = 1
      N=II-I
      WRITE (NJ,76) N
   73 CONTINUE
   76 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA4 CARDS READ)
      NCRDS=I
      DO 77 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      NCELR = RDATA(I,2)
      NCELRH(NRCH)=NCELR
C//   DO 78 J=6,25
C//   K = J-5
      DO 78 J = 3, 22
      K = J - 2
      IFLAG(NRCH,K)= RDATA(I,J)
   78 CONTINUE
   77 CONTINUE
      IF (ILIST.EQ.0) GO TO 427
      WRITE (NJ,507)
  507 FORMAT (1H0,10X,36H$$$ DATA TYPE 4 (COMPUTATIONAL REACH,
     *                16H FLAG FIELD) $$$,/)
      WRITE (NJ,207)
  207 FORMAT (10X,9HCARD TYPE,8X,20HREACH ELEMENTS/REACH,
     *        13X,19HCOMPUTATIONAL FLAGS)
      DO 208 I = 1, NCRDS
      WRITE (NJ,403) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,22)
  208 CONTINUE
  403 FORMAT (10X,2A4,A2,5X,F5.0,5X,F5.0,10X,20F2.0)
  427 CONTINUE
CCC
CCC                     I.6 Set up the ICLORD array, which is the
CCC                          numerical ordering of element id
CCC                          numbers from the headwaters to the
CCC                          end of the system.
CCC
      IOR=0
      DO 28 I=1,NREACH
      NCELR=NCELRH(I)
      DO 28 J=1,NCELR
      IOR=IOR+1
      ICLORD(I,J)=IOR
   28 CONTINUE
      IF(IOR-MC)  650,650,660
  660 WRITE(NJ,517)  IOR,MC
  517 FORMAT(1H0,5X,'*****',I5,'COMPUTATIONAL ELEMENTS EXECEED THE',
     *      ' PROGRAM DIMENSIONS OF',I5)
      NERROR=1
  650 CONTINUE
      NCELLS=IOR
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND05(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 05 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C +++++
C      CHARACTER*4       ADATA(ML,3),ENDT,ENDA,YES,REAC,LOCA,DUM
      CHARACTER*4       ADATA(ML,3),ENDA,REAC,LOCA,DUM
C +++++
      DIMENSION         RDATA(ML,9),SDATA(ML)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/,REAC/'REAC'/,
C     *     LOCA/'LOCA'/
      DATA ENDA/'ENDA'/ ,REAC/'REAC'/,LOCA/'LOCA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section J. (QUAL2 Step 3-5)
CCC                     J. Read in Type 5 data. (Hydraulic
CCC                         Coefficients)
CCC
      DO 80 I=1,II
      READ (NI,81) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,7)
   81 FORMAT (2A4,A2,5X,F5.0,2X,F8.0,5F10.0)
C//   IF (DATA(I,1)-ENDA) 80,85,80
      IF (ADATA(I,1) .EQ. ENDA) GO TO 85
   80 CONTINUE
      NERROR = 1
   84 I=I+1
      READ (NI,81) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,7)
C//   IF (DATA(I,1)-ENDA) 84,89,84
      IF (ADATA(I,1) .NE. ENDA) GO TO 84
C +++++
C   89 N=I-II
      N=I-II
C +++++
      WRITE (NJ,82) N
   82 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA5 CARDS READ)
      GO TO 83
   85 IF (I.GE.II) GO TO 83
      NERROR = 1
      N=II-I
      WRITE (NJ,86) N
   86 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA5 CARDS READ)
   83 CONTINUE
      NCRDS=I
      DO 87 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
CCC
CCC                     J.4.b Test ITRAP for hydraulic option.
CCC
      DISKO(NRCH)  = RDATA(I,2)
      IF(ITRAP.EQ.1) GO TO 183
      COEFQV(NRCH) = RDATA(I,3)
      EXPOQV(NRCH) = RDATA(I,4)
      COEFQH(NRCH) = RDATA(I,5)
      EXPOQH(NRCH) = RDATA(I,6)
      CMANN(NRCH)  = RDATA(I,7)
      GO TO 184
  183 SS1(NRCH)   = RDATA(I,3)
      SS2(NRCH)   = RDATA(I,4)
      WIDTH(NRCH) = RDATA(I,5)
      SLOPE(NRCH) = RDATA(I,6)
      CMANN(NRCH) = RDATA(I,7)
  184 CONTINUE
CC
CC               Change program to test each CMANN for the default
CC               value.  Delete the original CMANN test.
CC
C       IF(CMANN(NRCH).GT.0.0)ICHK=1
CC
CC              Add the following statements to redefine DATA(I,10),
CC               so that the default CMANN is printed with the
CC               output.
CC
C +++++
C      IF(CMANN(NRCH).EQ.0.0) CMANN(NRCH) = 0.02
      TVAL=CMANN(NRCH)
      IF(ABS(TVAL).LT.R0MIN) CMANN(NRCH) = 0.02
C +++++
      RDATA(I,7) = CMANN(NRCH)
CC
      IF(METRIC.EQ.0)GO TO 87
C3P0
      IF(ITRAP.EQ.1) GO TO 187
      CVXX=3.2808/35.3133**EXPOQV(NRCH)
      COEFQV(NRCH)=COEFQV(NRCH)*CVXX
      CVXX=3.2808/35.3133**EXPOQH(NRCH)
      COEFQH(NRCH)=COEFQH(NRCH)*CVXX
C3P0
      GO TO 87
187   CONTINUE
      WIDTH(NRCH) = WIDTH(NRCH)*3.2808
   87 CONTINUE
CC
CC              Delete DO loop 1119 and ICHK test.
CC
C + + + + + + + + +
C
C     COMMENT OUT THESE LINES  LCB  9/21
C
C     GO TO 88
C     IF (ICHK.EQ.1) GO TO 88
C     DO 1119 I=1,NREACH
C     NRCH=IRCHNO(IRCH)
C     CMANN(NRCH)=0.020
C1119 CONTINUE
CC
C + + + + + + + + +
C
C +++++
C   88 IF (ILIST.EQ.0) GO TO 428
      IF (ILIST.EQ.0) GO TO 428
C +++++
      WRITE (NJ,508)
  508 FORMAT (1H0,10X,31H$$$ DATA TYPE 5 (HYDRAULIC DATA,
     *                40H FOR DETERMINING VELOCITY AND DEPTH) $$$,/)
      IF(ITRAP.EQ.0 ) WRITE(NJ,208)
      IF(ITRAP.NE.0 )WRITE(NJ,1208)
1208    FORMAT(10X,'CARD TYPE',8X,'REACH  COEF-DSPN    SS1',7X,'SS2 ',
     *         4X,25HWIDTH     SLOPE     CMANN)
208     FORMAT(10X,'CARD TYPE',8X,'REACH  COEF-DSPN  COEFQV    ',
     1 'EXPOQV',4X,'COEFQH   EXPOQH     CMANN')
      DO 402 I = 1, NCRDS
      WRITE (NJ,404) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,7)
  402 CONTINUE
  404 FORMAT (10X,2A4,A2,5X,F5.0,2X,F8.2,5F10.3)
  428 CONTINUE
CQT
C3P0    BEGIN DATA TYPE 5A INPUT, TEMP AND LCD FOR SS SIMULATIONS
CQT
      IFGRVT=0
      DO 280 I=1,II
      READ (NI,281) (ADATA(I,J),J=1,3),SDATA(I),(RDATA(I,J),J=2,9)
  281 FORMAT(2A4,A2,5X,F5.0,4X,8F7.0)
CQT
C3P0    TEST FOR QUAL2E V2.2 INPUT DATA FILE
C3P0      IF V2.2, SKIP TO END OF FILE FOR LCD DATA.
C3P0
      IF(ADATA(I,1).EQ.REAC) GO TO 480
CQT
      IF (ADATA(I,1) .EQ. ENDA) GO TO 285
  280 CONTINUE
      NERROR = 1
  284 I=I+1
      READ (NI,281) (ADATA(I,J),J=1,3),SDATA(I),(RDATA(I,J),J=2,9)
      IF (ADATA(I,1) .NE. ENDA) GO TO 284
C +++++
C  289 N=I-II
      N=I-II
C +++++
      WRITE (NJ,282) N
  282 FORMAT (1H0,5X,16H***** TOO MANY (,I3,19H) DATA5A CARDS READ)
      GO TO 283
  285 IF (I.GE.II) GO TO 283
      IF(I.EQ.1) GO TO 383
      IF(I.EQ.2) GO TO 283
      NERROR = 1
      N=II-I
      WRITE (NJ,286) N
  286 FORMAT (1H0,5X,15H***** TOO FEW (,I3,19H) DATA5A CARDS READ)
      GO TO 283
CQT
C3P0  BRANCH FOR NO DATA TYPE 5A
CQT
  383 CONTINUE
      NCRDS=1
      IF(MODOPT(2).EQ.0) GO TO 288
      IF(ISS.EQ.0) GO TO 288
      NERROR=1
      WRITE(NJ,386)
  386 FORMAT(1H0,5X,'***** NO LOCAL CLIMATOLOGY DATA SUPPLIED FOR',
     1' STEADY STATE TEMPERATURE SIMULATION *****'/)
      GO TO 288
CQT
C3P0    BRANCH FOR QUAL2E V2.2 INPUT FILE
CQT
480   ITR=1
481   READ(NI,482,END=489) DUM
482   FORMAT(A4)
      IF(DUM.EQ.LOCA) GO TO 485
      ITR = ITR+ 1
      GO TO 481
CQT
C3P0    READ AND SAVE LCD
CQT
485   BACKSPACE NI
      READ(NI,483) (RDATA(I,J),J=4,8)
483   FORMAT(40X,5F8.0)
      ADATA(I,1) = 'TEMP'
      ADATA(I,2) = '/LCD'
      ADATA(I,3) = '  '
      SDATA(I) = 1.0
      RDATA(I,2) = ELEV
      RDATA(I,3) = DAT
      IF(METRIC.NE.0) RDATA(I,2)=RDATA(I,2)/3.2808
      RDATA(I,9) = 1.0
      ADATA(2,1) ='ENDA'
      ADATA(2,2) = 'TA5A'
      ADATA(2,3) = '  '
      SDATA(2) = 0.0
      DO 484 J=2,9
484   RDATA(2,J) = 0.0
      ITR1 = ITR+1
      DO 4841 K=1,ITR1
4841  BACKSPACE NI
      I=2
      GO TO 283
CQT
C3P0    CHECK FOR NO V2.2 LCD DATA
CQT
489   CONTINUE
      ADATA(1,1) = 'ENDA'
      ADATA(1,2) = 'TA5A'
      ADATA(1,3) = '  '
      SDATA(1) = 0.0
      DO 488 J=2,9
488   RDATA(1,J) = 0.0
      ITR1 = ITR+1
      DO 4891 K=1,ITR
4891  BACKSPACE NI
      GO TO 383
CQT
C3P0    END OF V2.2 TEST
CQT
  283 CONTINUE
      IF(I.NE.2.AND.NREACH.NE.1) IFGRVT=1
      IF(I.NE.2) GO TO 780
      II = NREACH +1
      DO 769 M=1,3
769   ADATA(II,M) = ADATA(2,M)
780   CONTINUE
      NCRDS=I
      DO 287 I=1,NREACH
      IR=I
      IF(NCRDS.NE.2) GO TO 782
      IR=1
      SDATA(I) = RDATA(I,1)
      DO 781 M=1,3
781   ADATA(I,M) = ADATA(1,M)
782   CONTINUE
      IRCH=IFIX(SDATA(I)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      RCHELV(NRCH) = RDATA(IR,2)
      RDATA(I,2) = RDATA(IR,2)
      RCHDAC(NRCH) = RDATA(IR,3)
      RDATA(I,3) = RDATA(IR,3)
      RCHCLD(NRCH) = RDATA(IR,4)
      RDATA(I,4) = RDATA(IR,4)
      RCHTDB(NRCH) = RDATA(IR,5)
      RDATA(I,5) = RDATA(IR,5)
      RCHTWB(NRCH) = RDATA(IR,6)
      RDATA(I,6) = RDATA(IR,6)
      RCHATM(NRCH) = RDATA(IR,7)
      RDATA(I,7) = RDATA(IR,7)
      RCHWND(NRCH) = RDATA(IR,8)*.6818
      RDATA(I,8) = RDATA(IR,8)
      RDATA(I,9) = RDATA(IR,9)
      IF(RDATA(I,9).LE.0.01) RDATA(I,9)=1.0
      RCHSAT(NRCH) = RDATA(I,9)
CQT
C3P0    CONVERT TO ENGLISH UNITS
CQT
      IF(METRIC.EQ.0)GO TO 287
      RCHELV(NRCH) = RCHELV(NRCH)*3.2808
      RCHTDB(NRCH) = RCHTDB(NRCH)*1.8 + 32.0
      RCHTWB(NRCH) = RCHTWB(NRCH)*1.8 + 32.0
      RCHATM(NRCH) = RCHATM(NRCH)*(29.9/1000.)
      RCHWND(NRCH) = RCHWND(NRCH)/0.3048
  287 CONTINUE
      NCRDS = NREACH + 1
CQT
C3P0     SEARCH FOR REFERENCE P, ELEV PAIR
CQT
      KR = 0
      REFZ = 0.0
      REFP = 0.0
      REFT = RCHTDB(I)
      DO 101 I=1,NREACH
      IF(RCHATM(I).LE.0.01) GO TO 101
      KR = KR + 1
      REFZ = RCHELV(I)
      REFP = RCHATM(I)
101   CONTINUE
      IF(KR.EQ.1) GO TO 120
      IF(KR.EQ.NREACH) GO TO 288
      NERROR = 1
      WRITE(NJ,105)
105   FORMAT(//'  *** ERROR! - MORE THAN ONE REFERENCE PAIR OF ',
     * 'PRESSURE-ELEVATION DATA PAIRS!'/)
      GO TO 288
120   CONTINUE
      GOVR = .01877
      DO 1000 I=1,NREACH
      AVTMP = (RCHTDB(I)+REFT)/2.0
      EXP1 = GOVR*(RCHELV(I)-REFZ)/(AVTMP+460.0)
      RCHATM(I) = REFP*EXP(-EXP1)
1000  CONTINUE
CQT
C3P0    REDEFINE RCHATM FOR PRINTING
CQT
      DO 130 I=1,NREACH
      RDATA(I,7) = RCHATM(I)
      IF(METRIC.NE.0) RDATA(I,7)=RCHATM(I)*(1000./29.9)
130   CONTINUE
  288 IF (ILIST.EQ.0) GO TO 628
      WRITE (NJ,608)
  608 FORMAT (1H0,10X,'$$$ DATA TYPE 5A (STEADY STATE TEMPERATURE',
     *' AND CLIMATOLOGY DATA) $$$',/)
      WRITE(NJ,6081)
6081    FORMAT(10X,'CARD TYPE',29X,'DUST     CLOUD   DRY BULB  WET',
     * ' BULB     ATM',15X,'SOLAR RAD'/
     *  26X,'REACH   ELEVATION     COEF     COVER',
     * '     TEMP      TEMP    PRESSURE     WIND   ATTENUATION')
      DO 302 I = 1, NCRDS
      WRITE (NJ,604) (ADATA(I,J),J=1,3),SDATA(I),(RDATA(I,J),J=2,9)
  302 CONTINUE
  604 FORMAT (10X,2A4,A2,5X,F5.0,2X,8F10.2)
  628 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND06(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 06 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C       INCLUDE 'ARRAYS.VAR'
C       INCLUDE 'CHARCT.VAR'
C       INCLUDE 'COMPRT.VAR'
C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C       INCLUDE 'WASTLD.VAR'
C
C +++++
C      CHARACTER*4       ADATA(ML,4),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,4),ENDA
C +++++
      DIMENSION         RDATA(ML,9)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CV1
CCC             NCASI Commentary, INDATA - Section K. (QUAL2 Step 3-6)
CCC                     K. Read in Type 6 data. (Deoxygenation and
CCC                         Reaeration Coefficients)
CCC
      DO 90 I=1,II
      READ (NI,91) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,8)
   91 FORMAT(2A4,A2,5X,F5.0,3F8.0,F4.0,3F8.0)
C//   IF (DATA(I,1)-ENDA) 90,95,90
      IF (ADATA(I,1) .EQ. ENDA) GO TO 95
   90 CONTINUE
      NERROR = 1
   94 I=I+1
      READ (NI,91) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,8)
C//   IF (DATA(I,1)-ENDA) 94,99,94
      IF (ADATA(I,1) .NE. ENDA) GO TO 94
C +++++
C   99 N=I-II
      N=I-II
C +++++
      WRITE (NJ,92) N
   92 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA6 CARDS READ)
      GO TO 93
   95 IF (I.GE.II) GO TO 93
      NERROR = 1
      N=II-I
      WRITE (NJ,96) N
   96 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA6 CARDS READ)
   93 CONTINUE
      NCRDS=I
      DO 97 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      CK1(NRCH)    = RDATA(I,2)
      CK3(NRCH)    = RDATA(I,3)
      CK4(NRCH)    = RDATA(I,4)
      K2OPT(NRCH)  = RDATA(I,5)
      CK2(NRCH)    = RDATA(I,6)
      COEQK2(NRCH) = RDATA(I,7)
      EXPQK2(NRCH) = RDATA(I,8)
      IF(METRIC.EQ.0) GO TO 97
      CK4(NRCH) = CK4(NRCH)/10.7636
      IF(K2OPT(NRCH).EQ.7) COEQK2(NRCH)=COEQK2(NRCH)*(1.0/35.3133)**
     1EXPQK2(NRCH)
      IF(K2OPT(NRCH).EQ.8) COEQK2(NRCH)=COEQK2(NRCH)/3.2808
   97 CONTINUE
      IF (ILIST.EQ.0) GO TO 429
      WRITE (NJ,509)
  509 FORMAT (1H0,10X,38H$$$ DATA TYPE 6 (REACTION COEFFICIENTS,
     *                38H FOR DEOXYGENATION AND REAERATION) $$$,/)
      WRITE (NJ,209)
  209 FORMAT(10X,'CARD TYPE',8X,'REACH     K1        K3',
     1'       SOD',9X,'K2OPT',5X,'K2',6X,'COEQK2    OR',
     2'   EXPQK2'/56X,'RATE',25X,'TSIV COEF  OR',
     3'    SLOPE'/79X,2('      FOR OPT 8'))
CC
CC              Change I to NREACH to avoid any ambiguity
CC               in the next IF statement.
CC
      IF((RDATA(NREACH,8)*1000.).GT.10.) GO TO 98
      DO 2000 I = 1, NCRDS
      WRITE (NJ,411) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,8)
 2000 CONTINUE
  411 FORMAT(10X,2A4,A2,5X,F5.0,2F10.2,F11.3,F10.0,F10.2,F11.3,
     1 4X,F11.5)
      GO TO 429
   98 CONTINUE
      DO 2001 I = 1, NCRDS
      WRITE (NJ,405) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,8)
 2001 CONTINUE
  405 FORMAT(10X,2A4,A2,5X,F5.0,2F10.2,F11.3,F10.0,F10.2,F11.3,
     1 4X,F11.3)
  429 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section L. (QUAL2 Step 3-6A)
CCC                     L. Read in Type 6A data. (N AND P COEFFICIENTS)
CCC
      DO 1100 I=1,II
      READ(NI,1101) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
 1101 FORMAT(3A4,A2,5X,F5.0,8F7.0)
C//   IF (DATA(I,1)-ENDA) 1100,1105,1100
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1105
 1100 CONTINUE
      NERROR=1
 1104 I=I+1
      READ(NI,1101) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
      IF (ADATA(I,1) .NE. ENDA) GO TO 1104
C//   IF (DATA(I,1)-ENDA)1104,1109,1104
C +++++
C 1109 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1102) N
 1102 FORMAT (1H0,5X,16H***** TOO MANY (,I3,19H) DATA6A CARDS READ)
      GO TO 1103
 1105 IF(I.GE.II) GO TO 1103
      IF(IDATA) 1120,1120,1130
 1120 NCRDS=1
      GO TO 1140
 1130 NERROR=1
      N=II-I
      WRITE (NJ,1106) N
 1106 FORMAT (1H0,5X,15H***** TOO FEW (,I3,19H) DATA6A CARDS READ)
 1103 CONTINUE
      NCRDS=I
      DO 1107 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      CKNH2(NRCH)  = RDATA(I,2)
      SVNH2(NRCH)  = RDATA(I,3)
      CKNH3(NRCH)  = RDATA(I,4)
      SNH3(NRCH)   = RDATA(I,5)
      CKNO2(NRCH)  = RDATA(I,6)
      CKPORG(NRCH) = RDATA(I,7)
      SVPORG(NRCH) = RDATA(I,8)
      SPHOS(NRCH)  = RDATA(I,9)
      IF (METRIC.EQ.0) GO TO 1107
      SNH3(NRCH)=SNH3(NRCH)/10.7636
      SPHOS(NRCH)=SPHOS(NRCH)/10.7636
 1107 CONTINUE
 1140 IF(ILIST .EQ. 0) GO TO 1199
      WRITE(NJ,1110)
CC ->-> CHANGED FORMAT 1110 FOR IBM T.WILSON 6/15/84 <-<-
C 1110 FORMAT(1H0,10X,59H $$$ DATA TYPE 6A ( NITROGEN  AND PHOSPHOR
C     $US CONSTANTS) $$$,/)
 1110 FORMAT(1H0,10X,' $$$ DATA TYPE 6A (NITROGEN AND ',
     1  'PHOSPHORUS CONSTANTS) $$$',/)
      WRITE(NJ,1111)
 1111 FORMAT(10X,'CARD TYPE',11X,'REACH    CKNH2    SETNH2     CK',
     1'NH3      SNH3     CKNO2     CKPORG   SETPORG     SPO4')
      DO 3000 I = 1, NCRDS
      WRITE(NJ,1112) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
 3000 CONTINUE
 1112 FORMAT(10X,3A4,A2,5X,F5.0,8F10.2)
 1199 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section M. (QUAL2 Step 3-6B)
CCC                     M. Read in Type 6B data. (Algae/Other
CCC                         Coefficients)
CCC
      DO 1200 I=1,II
      READ(NI,1201) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
 1201 FORMAT(3A4,A2,5X,F5.0,7F7.0)
C//   IF (DATA(I,1)-ENDA) 1200,1205,1200
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1205
 1200 CONTINUE
      NERROR=1
 1204 I=I+1
      READ(NI,1201) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
C//   IF (DATA(I,1)-ENDA)1204,1209,1204
      IF (ADATA(I,1) .NE. ENDA) GO TO 1204
C +++++
C 1209 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1202) N
 1202 FORMAT (1H0,5X,16H***** TOO MANY (,I3,19H) DATA6B CARDS READ)
      GO TO 1203
 1205 IF(I.GE.II) GO TO 1203
      IF(IDATA.EQ.1.OR.IDATA1.EQ.1) GO TO 1230
      NCRDS=1
      GO TO 1250
 1230 NERROR=1
      N=II-I
      WRITE (NJ,1206) N
 1206 FORMAT (1H0,5X,15H***** TOO FEW (,I3,19H) DATA6B CARDS READ)
 1203 CONTINUE
      NCRDS=I
      DO 1207 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
C3P0       ALGAE  PARAMETER DEFAULTS FOR MISSING VALUES OF ALPHAO (50.) AND
C3P0           LIGHT EXTINCTION COEFFICIENT (0.01)
      ALPHAO(NRCH) = RDATA(I,2)
      IF(ALPHAO(NRCH).LE.0.001) ALPHAO(NRCH)=50.
      RDATA(I,2) = ALPHAO(NRCH)
      ALGSET(NRCH) = RDATA(I,3)
      EXCOEF(NRCH) = RDATA(I,4)
      IF(EXCOEF(NRCH).LE.0.00001) EXCOEF(NRCH)=0.01
      RDATA(I,4) = EXCOEF(NRCH)
C3P0
      CK5(NRCH)    = RDATA(I,5)
      CKANC(NRCH)  = RDATA(I,6)
      SETANC(NRCH) = RDATA(I,7)
      SRCANC(NRCH) = RDATA(I,8)
      IF(METRIC.EQ.0) GO TO 1207
      ALGSET(NRCH) = ALGSET(NRCH)*3.2808
      SRCANC(NRCH) = SRCANC(NRCH)/10.7636
      EXCOEF(NRCH)=EXCOEF(NRCH)/3.2808
 1207 CONTINUE
 1250 IF(ILIST.EQ.0) GO TO 1299
      WRITE(NJ,1210)
 1210 FORMAT(1H0,10X,'$$$ DATA TYPE 6B (ALGAE/OTHER COEFFICIENTS)',
     1' $$$'/)
      WRITE(NJ,1211)
1211    FORMAT(10X,'CARD TYPE',11X,'REACH    ALPHAO    ALGSET',
     1'    EXCOEF      CK5     CKANC',
     2'    SETANC    SRCANC'/69X,'CKCOLI')
      DO 3002 I = 1, NCRDS
      WRITE(NJ,1212) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
 3002 CONTINUE
1212    FORMAT(10X,3A4,A2,5X,F5.0,7F10.2)
 1299 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND07(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 07 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C +++++
C      CHARACTER*4       ADATA(ML,4),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,4),ENDA
C +++++
      DIMENSION         RDATA(ML,9)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section N. (QUAL2 Step 3-7)
CCC                     N. Read in Type 7 data. (Initial
CCC                         Conditions)
CCC
      DO 110 I=1,II
      READ (NI,111) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
111     FORMAT(3A4,A2,5X,F5.0,8F7.0)
C//   IF (DATA(I,1)-ENDA) 110,115,110
      IF (ADATA(I,1) .EQ. ENDA) GO TO 115
  110 CONTINUE
      NERROR=1
  114 I=I+1
      READ (NI,111) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
C//   IF (DATA(I,1)-ENDA) 114,119,114
      IF (ADATA(I,1) .NE. ENDA) GO TO 114
C +++++
C  119 N=I-II
      N=I-II
C +++++
      WRITE (NJ,112) N
  112 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA7 CARDS READ)
      GO TO 113
  115 IF (I.GE.II) GO TO 113
      NERROR = 1
      N=II-I
      WRITE (NJ,116) N
  116 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA7 CARDS READ)
  113 CONTINUE
      NCRDS=I
      DO 117 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
CQ2E
CQ2E    TEST FOR TEMP LT 35 F (2 C) AND DEFAULT TO 68 F (20 C).
CQ2E
CLB
CLB - 01/92 Corrected logic for default temperature value.
CLB
      IF(MODOPT(2).NE.0) THEN
        IF(RDATA(I,2).LT.35.0.AND.METRIC.EQ.0) RDATA(I,2)=68.0
        IF(RDATA(I,2).LT. 2.0.AND.METRIC.EQ.1) RDATA(I,2)=20.0
      ENDIF
CLB
      TINIT(NRCH)   = RDATA(I,2)
      IF(METRIC.EQ.1)TINIT(NRCH)=TINIT(NRCH)*1.8+32.
      DOINIT(NRCH)  = RDATA(I,3)
      BOINIT(NRCH)  = RDATA(I,4)
      COINIT(NRCH,1)= RDATA(I,5)
      COINIT(NRCH,2)= RDATA(I,6)
      COINIT(NRCH,3)= RDATA(I,7)
      ANCIT(NRCH)   = RDATA(I,8)
      COLIIT(NRCH)  = RDATA(I,9)
C
CQE            DEFAULT INITIAL TEMPERATURE TO 20 C.
CLB
CLB - 01/92 Corrected logic for default temperature value.
CLB
      IF(RDATA(I,2).LE.R0MIN.AND.MODOPT(2).EQ.0) THEN
         IF(METRIC.EQ.0) RDATA(I,2) = 32.0
         TINIT(NRCH) = 32.0
      ENDIF
CLB
  117 CONTINUE
      IF (ILIST.EQ.0) GO TO 430
      WRITE (NJ,510)
  510 FORMAT (1H0,10X,40H$$$ DATA TYPE 7 (INITIAL CONDITIONS) $$$,/)
      WRITE (NJ,210)
210     FORMAT(10X,'CARD TYPE',11X,'REACH    TEMP       D.O.',
     1'      BOD       CM-1      CM-2      CM-3       ANC',
     2'      COLI')
      DO 208 I = 1, NCRDS
      WRITE (NJ,406) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,9)
  208 CONTINUE
406     FORMAT(10X,3A4,A2,5X,F5.0,8F10.2)
  430 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section O. (QUAL2 Step 3-7A)
CCC                     O. Read in Type 7A data. (Initial N,
CCC                         P, Algae, etc.)
CCC
      DO 1302 I=1,II
      READ(NI,1301) (ADATA(I,J), J=1,4),(RDATA(I,J),J=1,8)
 1301 FORMAT(3A4,A2,5X,F5.0,7F7.0)
C//   IF (DATA(I,1)-ENDA) 1302,1303,1302
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1303
 1302 CONTINUE
      NERROR=1
 1304 I=I+1
      READ(NI,1301) (ADATA(I,J), J=1,4),(RDATA(I,J),J=1,8)
C//   IF (DATA(I,1)-ENDA) 1304,1305,1304
      IF (ADATA(I,1) .NE. ENDA) GO TO 1304
C +++++
C 1305 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1306) N
 1306 FORMAT (1H0,5X,16H***** TOO MANY (,I3,20H) DATA 7A CARDS READ)
      GO TO 1307
 1303 IF (I.GE.II) GO TO 1307
      IF(IDATA) 1321,1321,1330
 1321 NCRDS=1
       GO TO 1350
 1330 NERROR=1
      N=II-I
      WRITE (NJ,1308) N
 1308 FORMAT (1H0,5X,15H***** TOO FEW (,I3,20H) DATA 7A CARDS READ)
 1307 CONTINUE
      NCRDS=I
      DO 1309 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
C3.0      IF(MODOPT(4).NE.0) ALGIT(NRCH) = RDATA(I,2)/ALPHAO(NRCH)
      ALGIT(NRCH) = RDATA(I,2)
      CNH2IT(NRCH) = RDATA(I,3)
      CNH3IT(NRCH) = RDATA(I,4)
      CNO2IT(NRCH) = RDATA(I,5)
      CNO3IT(NRCH) = RDATA(I,6)
      PORGIT(NRCH) = RDATA(I,7)
      PHOSIT(NRCH) = RDATA(I,8)
 1309 CONTINUE
 1350 IF (ILIST.EQ.0) GO TO 1320
      WRITE (NJ,1310)
 1310 FORMAT (1H0,10X,'$$$ DATA TYPE 7A (INITIAL CONDITIONS FOR CHOROP',
     1  'HYLL A, NITROGEN, AND PHOSPHORUS) $$$'/)
      WRITE (NJ,1311)
1311    FORMAT(10X,'CARD TYPE',11X,'REACH    CHL-A     ORG-N',
     1'     NH3-N     NO2-N     NO3-N     ORG-P     DIS-P')
      DO 209 I = 1, NCRDS
      WRITE(NJ,1312) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
  209 CONTINUE
1312    FORMAT(10X,3A4,A2,5X,F5.0,7F10.2)
 1320 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND08(II)
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 08 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
C      CHARACTER*4      ADATA(ML,4),ENDT,ENDA,YES
      CHARACTER*4      ADATA(ML,4),ENDA
C +++++
      DIMENSION        RDATA(ML,10)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section P. (QUAL2 Step3-8)
CCC                     P. Read in Type 8 data. (Incremental
CCC                         Inflow Conditions)
CCC
      DO 120 I=1,II
      READ (NI,121) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,10)
121     FORMAT(3A4,A2,5X,F5.0,2F7.0,7F6.0)
C//   IF (DATA(I,1)-ENDA) 120,125,120
      IF (ADATA(I,1) .EQ. ENDA) GO TO 125
  120 CONTINUE
      NERROR=1
  124 I=I+1
      READ (NI,121) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,10)
C//   IF (DATA(I,1)-ENDA) 124,129,124
      IF (ADATA(I,1) .NE. ENDA) GO TO 124
C +++++
C  129 N=I-II
      N=I-II
C +++++
      WRITE (NJ,122) N
  122 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA8 CARDS READ)
      GO TO 123
  125 IF (I.GE.II) GO TO 123
      NERROR = 1
      N=II-I
      WRITE (NJ,126) N
  126 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA8 CARDS READ)
  123 CONTINUE
      NCRDS=I
      DO 127 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
      QI(NRCH)      = RDATA(I,2)
      TI(NRCH)      = RDATA(I,3)
      DOI(NRCH)     = RDATA(I,4)
      BODI(NRCH)    = RDATA(I,5)
      CONSI(NRCH,1) = RDATA(I,6)
      CONSI(NRCH,2) = RDATA(I,7)
      CONSI(NRCH,3) = RDATA(I,8)
      ANCI(NRCH)    = RDATA(I,9)
      COLIR(NRCH)   = RDATA(I,10)
      IF(METRIC.EQ.0)GO TO 127
      QI(NRCH)=35.3133*QI(NRCH)
      TI(NRCH)=1.8*TI(NRCH)+32.0
  127 CONTINUE
      IF (ILIST.EQ.0) GO TO 431
      WRITE (NJ,511)
  511 FORMAT (1H0,10X,35H$$$ DATA TYPE 8 (INCREMENTAL INFLOW,
     *       16H CONDITIONS) $$$)
      WRITE (NJ,211)
211     FORMAT(/10X,'CARD TYPE',11X,'REACH     FLOW      TEMP',
     1'      D.O.       BOD      CM-1      CM-2      CM-3',
     2'       ANC      COLI')
      DO 208 I = 1, NCRDS
      WRITE (NJ,407) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,10)
  208 CONTINUE
407     FORMAT(10X,3A4,A2,5X,F5.0,F10.3,8F10.2)
  431 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section Q. (QUAL2 Step 3-8A)
CCC                     Q. Read in Type 8A data. (Algae, N, P,
CCC                         etc. for Incremental Inflow)
CCC
      DO 1400 I=1,II
      READ(NI,1401) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
 1401 FORMAT(3A4,A2,5X,F5.0,8F7.0)
C//   IF (DATA(I,1)-ENDA) 1400,1402,1400
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1402
 1400 CONTINUE
      NERROR=1
 1403 I=I+1
      READ(NI,1401) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
C//   IF (DATA(I,1)-ENDA) 1403,1404,1403
      IF (ADATA(I,1) .NE. ENDA) GO TO 1403
C +++++
C 1404 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1405) N
 1405 FORMAT (1H0,5X,16H***** TOO MANY (,I3,20H) DATA 8A CARDS READ)
      GO TO 1406
 1402 IF (I.GE.II) GO TO 1406
      IF(IDATA)1420,1420,1430
 1420 NCRDS=1
      GO TO 1450
 1430 NERROR=1
      N=II-I
      WRITE (NJ,1407) N
 1407 FORMAT (1H0,5X,15H***** TOO FEW (,I3,20H) DATA 8A CARDS READ)
 1406 CONTINUE
      NCRDS=I
      DO 1408 I=1,NREACH
      IRCH=IFIX(RDATA(I,1)*10.+0.0001)
      NRCH=IRCHNO(IRCH)
C3.0      IF(MODOPT(4).NE.0) ALGI(NRCH) = RDATA(I,2)/ALPHAO(NRCH)
      ALGI(NRCH) = RDATA(I,2)
      CNH2I(NRCH) = RDATA(I,3)
      CNH3I(NRCH) = RDATA(I,4)
      CNO2I(NRCH) = RDATA(I,5)
      CNO3I(NRCH) = RDATA(I,6)
      PORGI(NRCH) = RDATA(I,7)
      PHOSI(NRCH) = RDATA(I,8)
 1408 CONTINUE
 1450 IF(ILIST .EQ.0) GO TO 1409
      WRITE (NJ,1410)
 1410 FORMAT (1H0,10X,36H$$$ DATA TYPE 8A (INCREMENTAL INFLOW ,
     *       40H CONDITIONS FOR CHLOROPHYLL A, NITROGEN,,
     1' AND PHOSPHORUS) $$$'/)
      WRITE (NJ,1411)
1411    FORMAT(10X,'CARD TYPE',11X,'REACH    CHL-A',
     1'     ORG-N     NH3-N     NO2-N     NO3-N',
     2'     ORG-P     DIS-P')
      DO 209 I = 1, NCRDS
      WRITE(NJ,1412) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,8)
  209 CONTINUE
1412    FORMAT(10X,3A4,A2,5X,F5.0,7F10.2)
 1409 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND09
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 09 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
C      CHARACTER*4       ADATA(ML,9),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,9),ENDA
C +++++
      DIMENSION         RDATA(ML,4)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section R. (QUAL2 Step 3-9)
CCC                     R. Read in Type 9 data. (Stream
CCC                         Junction Information)
CCC
      II=NJUNC+1
      DO 130 I=1,II
      READ (NI,131) (ADATA(I,J),J=1,4),RDATA(I,1),
     *              (ADATA(I,J),J=5,9),(RDATA(I,J),J=2,4)
  131 FORMAT (3A4,A3,5X,F5.0,5X,5A4,3(5X,F5.0))
C//   IF (DATA(I,1)-ENDA) 130,135,130
      IF (ADATA(I,1) .EQ. ENDA) GO TO 135
  130 CONTINUE
      NERROR=1
  134 I=I+1
      READ (NI,131) (ADATA(I,J),J=1,4),RDATA(I,1),
     *              (ADATA(I,J),J=5,9),(RDATA(I,J),J=2,4)
C//   IF (DATA(I,1)-ENDA) 134,139,134
      IF (ADATA(I,1) .NE. ENDA) GO TO 134
C +++++
C  139 N=I-II
      N=I-II
C +++++
      WRITE (NJ,132) N
  132 FORMAT (1H0,5X,16H***** TOO MANY (,I3,18H) DATA9 CARDS READ)
      GO TO 133
  135 IF (I.GE.II) GO TO 133
      NERROR = 1
      N=II-I
      WRITE (NJ,136) N
  136 FORMAT (1H0,5X,15H***** TOO FEW (,I3,18H) DATA9 CARDS READ)
  133 CONTINUE
      NCRDS=I
      DO 137 I=1,NJUNC
      IJUNC = RDATA(I,1)
C//   DO 138 J=6,10
C//   K = J-5
C*    DO 138 J = 5, 9
C*    K = J - 4
C*    JUNCID(IJUNC,K) = ADATA(I,J)
C*138 CONTINUE
      JUNC(IJUNC,1) = RDATA(I,2)
      JUNC(IJUNC,2) = RDATA(I,3)
      JUNC(IJUNC,3) = RDATA(I,4)
  137 CONTINUE
      IF (ILIST.EQ.0) GO TO 432
      WRITE (NJ,512)
  512 FORMAT (1H0,10X,38H$$$ DATA TYPE 9 (STREAM JUNCTIONS) $$$,/)
      WRITE (NJ,212)
  212 FORMAT (10X,9HCARD TYPE,14X,24HJUNCTION ORDER AND IDENT,
     *         9X,25HUPSTRM   JUNCTION    TRIB)
      DO 208 I = 1, NCRDS
      WRITE (NJ,408) (ADATA(I,J),J=1,4),RDATA(I,1),
     *               (ADATA(I,J),J=5,9),(RDATA(I,J),J=2,4)
  208 CONTINUE
  408 FORMAT (10X,3A4,A3,5X,F5.0,5X,5A4,5X,F5.0,5X,F5.0,5X,F5.0)
  432 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND10
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 10 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
C      CHARACTER*4       ADATA(ML,7),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,7),ENDA
C +++++
      DIMENSION         RDATA(ML,10)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section S. (QUAL2 Step 3-10)
CCC                     S. Read in Type 10 data. (Headwater
CCC                         Information)
CCC
      II = NHWTRS+1
      DO 140 I=1,II
      READ (NI,141) (ADATA(I,J),J=1,3),RDATA(I,1),
     *              (ADATA(I,J),J=4,7),(RDATA(I,J),J=2,8)
141     FORMAT(2A4,A2,4X,F5.0,4A4,F9.0,6F6.0)
C//   IF (DATA(I,1)-ENDA) 140,145,140
      IF (ADATA(I,1) .EQ. ENDA) GO TO 145
  140 CONTINUE
      NERROR=1
  144 I=I+1
      READ (NI,141) (ADATA(I,J),J=1,3),RDATA(I,1),
     *              (ADATA(I,J),J=4,7),(RDATA(I,J),J=2,8)
C//   IF (DATA(I,1)-ENDA) 144,149,144
      IF (ADATA(I,1) .NE. ENDA) GO TO 144
C +++++
C  149 N=I-II
      N=I-II
C +++++
      WRITE (NJ,142) N
  142 FORMAT (1H0,5X,16H***** TOO MANY (,I3,19H) DATA10 CARDS READ)
      GO TO 143
  145 IF (I.GE.II) GO TO 143
      NERROR = 1
      N=II-I
      WRITE (NJ,146) N
  146 FORMAT (1H0,5X,15H***** TOO FEW (,I3,19H) DATA10 CARDS READ)
  143 CONTINUE
      NCRDS=I
      DO 147 I=1,NHWTRS
      NHW = RDATA(I,1)
C//   DO 148 J=5,8
C//   K = J-3
      DO 148 J = 4, 7
      K = J - 2
      HWTRID(NHW,K) = ADATA(I,J)
  148 CONTINUE
      HWFLOW(NHW)   = RDATA(I,2)
      HWTEMP(NHW)   = RDATA(I,3)
      IF(METRIC.GT.0)HWFLOW(NHW)=35.3133*HWFLOW(NHW)
      IF(METRIC.GT.0)HWTEMP(NHW)=1.8*HWTEMP(NHW)+32.0
      HWDO(NHW)     = RDATA(I,4)
      HWBOD(NHW)    = RDATA(I,5)
      HWCONS(NHW,1) = RDATA(I,6)
      HWCONS(NHW,2) = RDATA(I,7)
      HWCONS(NHW,3) = RDATA(I,8)
      QATOT(NHW)=HWFLOW(NHW)
  147 CONTINUE
      IF (ILIST.EQ.0) GO TO 433
      WRITE (NJ,513)
  513 FORMAT (1H0,10X,40H$$$ DATA TYPE 10 (HEADWATER SOURCES) $$$,/)
      WRITE (NJ,213)
213     FORMAT(10X,'CARD TYPE',4X,'HDWTR     NAME',14X,
     1'FLOW      TEMP      D.O.       BOD      CM-1',
     2'      CM-2      CM-3'/23X,'ORDER')
      DO 208 I = 1, NCRDS
      WRITE (NJ,409) (ADATA(I,J),J=1,3),RDATA(I,1),
     *               (ADATA(I,J),J=4,7),(RDATA(I,J),J=2,8)
  208 CONTINUE
409     FORMAT(10X,2A4,A2,2X,F5.0,2X,4A4,7F10.2)
  433 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section T. (QUAL2 Step 3-10A)
CCC                     T. Read in Type 10A data. (Algae, N, P,
CCC                         etc. Headwater Information)
CCC
      DO 1500 I=1,II
      READ(NI,1501) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
C1501    FORMAT(2A4,A2,5X,F5.0,9F6.0)
1501    FORMAT(2A4,A2,5X,F5.0,F6.0,E6.0,7F6.0)
C//   IF (DATA(I,1)-ENDA) 1500,1502,1500
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1502
 1500 CONTINUE
      NERROR=1
 1503 I=I+1
      READ(NI,1501) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
C//   IF (DATA(I,1)-ENDA) 1503,1504,1503
      IF (ADATA(I,1) .NE. ENDA) GO TO 1503
C +++++
C 1504 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1505) N
 1505 FORMAT (1H0,5X,16H***** TOO MANY (,I3,21H) DATA 10A CARDS READ)
      GO TO 1506
 1502 IF (I.GE.II) GO TO 1506
      IF(IDATA.EQ.1.OR.IDATA1.EQ.1) GO TO 1530
      NCRDS=1
      GO TO 1550
 1530 NERROR=1
      N=II-I
      WRITE (NJ,1507) N
 1507 FORMAT (1H0,5X,15H***** TOO FEW (,I3,21H) DATA 10A CARDS READ)
 1506 CONTINUE
      NCRDS=I
      DO 1508 I=1,NHWTRS
      NHW         = RDATA(I,1)
      HWANC(NHW)  = RDATA(I,2)
      HWCOLI(NHW) = RDATA(I,3)
      HWALG(NHW)  = RDATA(I,4)
      HWNH2(NHW)  = RDATA(I,5)
      HWNH3(NHW)  = RDATA(I,6)
      HWNO2(NHW)  = RDATA(I,7)
      HWNO3(NHW)  = RDATA(I,8)
      HWPORG(NHW) = RDATA(I,9)
      HWPHOS(NHW) = RDATA(I,10)
 1508 CONTINUE
C3.0      NHW = 0
C3.0      DO 1560 I=1,NREACH
C3.0      NCELR = NCELRH(I)
C3.0      DO 1560 J=1,NCELR
C3.0      IFL = IFLAG(I,J)
C3.0      IF(IFL.NE.1) GO TO 1560
C3.0      NHW = NHW + 1
C3.0      IF(MODOPT(4).NE.0) HWALG(NHW) = HWALG(NHW)/ALPHAO(I)
C3.01560  CONTINUE
 1550 IF(ILIST .EQ. 0) GO TO 1509
      WRITE (NJ,1510)
 1510 FORMAT(1H0,10X,29H$$$ DATA TYPE 10A (HEADWATER ,
     *      28HCONDITIONS FOR CHLOROPHYLL, ,
     *       21HNITROGEN, PHOSPHORUS,/30X,25HCOLIFORM AND SELECTED NON,
     *       30H-CONSERVATIVE CONSTITUENT) $$$,/)
      WRITE (NJ,1511)
1511    FORMAT(10X,'CARD TYPE     HDWTR     ANC     COLI',
     1'    CHL-A    ORG-N    NH3-N    NO2-N    NO3-N',
     2'    ORG-P    DIS-P'/24X,'ORDER')
      DO 209 I = 1, NCRDS
      WRITE(NJ,1512) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
  209 CONTINUE
1512    FORMAT(10X,2A4,A2,3X,F5.0,F9.2,E9.2,7F9.2)
 1509 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND11
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 11 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
C      CHARACTER*4       ADATA(ML,6),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,6),ENDA
C +++++
      DIMENSION         RDATA(ML,10)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CCC
CCC             NCASI Commentary, INDATA - Section U. (QUAL2 Step 3-11)
CCC                     U. Read in Type 11 data. (Point Source/
CCC                         Withdrawal Information)
CCC
      II = NWASTE+1
      DO 150 I=1,II
      READ (NI,151) (ADATA(I,J),J=1,3),RDATA(I,1),
     *              (ADATA(I,J),J=4,6),(RDATA(I,J),J=2,9)
151     FORMAT(2A4,A1,5X,F5.0,3A4,F5.0,F8.0,6F6.0)
C//   IF (DATA(I,1)-ENDA) 150,155,150
      IF (ADATA(I,1) .EQ. ENDA) GO TO 155
  150 CONTINUE
      NERROR = 1
  154 I = I + 1
      READ (NI,151) (ADATA(I,J),J=1,3),RDATA(I,1),
     *              (ADATA(I,J),J=4,6),(RDATA(I,J),J=2,9)
C//   IF (DATA(I,1)-ENDA) 154,159,154
      IF (ADATA(I,1) .NE. ENDA) GO TO 154
C +++++
C  159 N=I-II
      N=I-II
C +++++
      WRITE (NJ,152) N
  152 FORMAT (1H0,5X,16H***** TOO MANY (,I3,19H) DATA11 CARDS READ)
      GO TO 153
  155 IF (I.GE.II) GO TO 153
      NERROR = 1
      N=II-I
      WRITE (NJ,156) N
  156 FORMAT (1H0,5X,15H***** TOO FEW (,I3,19H) DATA11 CARDS READ)
  153 CONTINUE
      NCRDS=I
      DO 157 I=1,NWASTE
      NWS = RDATA(I,1)
C//   DO 158 J=5,7
C//   K = J-2
C*    DO 158 J = 4, 6
C*    K = J - 1
C*    WASTID(NWS,K) = ADATA(I,J)
C*158 CONTINUE
      TRFACT(NWS)   = RDATA(I,2)
CDD -----
CDD   Date: Wednesday, 16 May 1990.  Time: 09:24:07.
CDD   To transform TRFACT specified as a percentage into a fraction.
CDD   Transformation assumes percentage specified is 1.0 <= TRFACT <= 100.0
CDD   0.0 <= TRFACT < 1.0 is assumed to be percentage input as fraction.
CDD   Reference: See TRFACT in 1987 QUAL2E manual.
CDD
      IF (TRFACT(NWS).GE.1.0.AND.TRFACT(NWS).LE.100.0) THEN
         TRFACT(NWS) = TRFACT(NWS)/100.0
         WRITE (NJ,1589)
 1589    FORMAT (1H0,5X,'TRFACT CONVERTED FROM PERCENTAGE TO FRACTION')
      ENDIF
CDD -----
      WSFLOW(NWS)   = RDATA(I,3)
      WSTEMP(NWS)   = RDATA(I,4)
      WSDO(NWS)     = RDATA(I,5)
      WSBOD(NWS)    = RDATA(I,6)
      WSCONS(NWS,1) = RDATA(I,7)
      WSCONS(NWS,2) = RDATA(I,8)
      WSCONS(NWS,3) = RDATA(I,9)
      IF (METRIC.EQ.0) GO TO 157
      WSFLOW(NWS)=35.3133*WSFLOW(NWS)
      WSTEMP(NWS)=1.8*WSTEMP(NWS)+32.0
  157 CONTINUE
      IF (ILIST.EQ.0) GO TO 434
      WRITE (NJ,514)
  514 FORMAT (1H0,10X,38H$$$ DATA TYPE 11 (POINT SOURCE / POINT,
     *       28H SOURCE CHARACTERISTICS) $$$,/)
      WRITE (NJ,214)
214     FORMAT(24X,'POINT'/10X,'CARD TYPE      LOAD',
     1'    NAME',14X,'EFF     FLOW     TEMP     D.O.      BOD',
     2'     CM-1     CM-2     CM-3'/24X,'ORDER')
      DO 208 I = 1, NCRDS
      WRITE (NJ,410) (ADATA(I,J),J=1,3),RDATA(I,1),
     *               (ADATA(I,J),J=4,6),(RDATA(I,J),J=2,9)
  208 CONTINUE
410     FORMAT(10X,2A4,A1,3X,F5.0,2X,3A4,4X,8F9.2)
  434 CONTINUE
CCC
CCC             NCASI Commentary, INDATA - Section V. (QUAL2 Step 3-11A)
CCC                     V. Read in Type 11A data. (Algae, N, P,
CCC                         etc. for Point Source/ Withdrawal)
CCC
      DO 1602 I=1,II
      READ(NI,1601) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
C1601    FORMAT(2A4,A2,5X,F5.0,9F6.0)
1601    FORMAT(2A4,A2,5X,F5.0,F6.0,E6.0,7F6.0)
C//   IF (DATA(I,1)-ENDA) 1602,1621,1602
      IF (ADATA(I,1) .EQ. ENDA) GO TO 1621
 1602 CONTINUE
      NERROR=1
 1605 I=I+1
      READ(NI,1601) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
C//   IF (DATA(I,1)-ENDA) 1605,1607,1605
      IF (ADATA(I,1) .NE. ENDA) GO TO 1605
C +++++
C 1607 N=I-II
      N=I-II
C +++++
      WRITE (NJ,1620) N
 1620 FORMAT (1H0,5X,16H***** TOO MANY (,I3,21H) DATA 11A CARDS READ)
      GO TO 1604
 1621 IF (I.GE.II) GO TO 1604
      IF(IDATA.EQ.1.OR.IDATA1.EQ.1) GO TO 1640
      NCRDS=1
      GO TO 1650
 1640 NERROR=1
      N=II-I
      WRITE (NJ,1622) N
 1622 FORMAT (1H0,5X,15H***** TOO FEW (,I3,21H) DATA 11A CARDS READ)
 1604 CONTINUE
      NCRDS=I
      DO 1606 I=1,NWASTE
      NWS         = RDATA(I,1)
      WSANC(NWS)  = RDATA(I,2)
      WSCOLI(NWS) = RDATA(I,3)
      WSALG(NWS)  = RDATA(I,4)
      WSNH2(NWS)  = RDATA(I,5)
      WSNH3(NWS)  = RDATA(I,6)
      WSNO2(NWS)  = RDATA(I,7)
      WSNO3(NWS)  = RDATA(I,8)
      WSPORG(NWS) = RDATA(I,9)
      WSPHOS(NWS) = RDATA(I,10)
 1606 CONTINUE
C3.0      NWS = 0
C3.0      DO 1660 I=1,NREACH
C3.0      NCELR = NCELRH(I)
C3.0      DO 1660 J=1,NCELR
C3.0      IFL = IFLAG(I,J)
C3.0      IF(IFL.LT.6) GO TO 1660
C3.0      NWS = NWS + 1
C3.0      IF(MODOPT(4).NE.0) WSALG(NWS) = WSALG(NWS)/ALPHAO(I)
C3.01660    CONTINUE
 1650 IF(ILIST .EQ. 0) GO TO 1699
      WRITE (NJ,1610)
 1610 FORMAT (1H0,10X,41H$$$ DATA TYPE 11A (POINT SOURCE CHARACTER,
     *       45HISTICS - CHLOROPHYLL A, NITROGEN, PHOSPHORUS,/30X,
     *       51HCOLIFORMS AND SELECTED NON-CONSERVATIVE CONSTITUENT,
     *       5H) $$$,/)
      WRITE(NJ,1611)
1611    FORMAT(24X,'POINT'/10X,'CARD TYPE      LOAD',
     1'     ANC     COLI    CHL-A    ORG-N    NH3-N    NO2-N',
     2'    N03-N    ORG-P    DIS-P'/24X,'ORDER')
      NCRDS=NCRDS-1
      IF (IDATA.EQ.0.AND.IDATA1.EQ.0) GO TO 1655
      DO 1615 I=1,NCRDS
      NWS  = RDATA(I,2)
      FNWS = NWS
      WRITE(NJ,1612) (ADATA(I,J),J=1,3),(RDATA(I,J),J=1,10)
1612    FORMAT(10X,2A4,A2,3X,F5.0,F9.2,E9.2,7F9.2)
C1612    FORMAT(10X,2A4,A2,3X,F5.0,9F9.2)
 1615 CONTINUE
 1655 WRITE (NJ,1612) (ADATA(NCRDS+1,J),J=1,3),
     *                (RDATA(NCRDS+1,J),J=1,10)
 1699 CONTINUE
C + + + + + + + + + + +
C
      RETURN
      END
      SUBROUTINE IND12
C
C + + + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 12 FOR A QUAL2E SIMULATION
C
C + + + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
C +++++
C      CHARACTER*4       ADATA(ML,4),ENDT,ENDA,YES
      CHARACTER*4       ADATA(ML,4),ENDA
C +++++
      DIMENSION         RDATA(ML,7)
C +++++
C      DATA ENDT/'ENDT'/ , ENDA/'ENDA'/ , YES/' YES'/
      DATA ENDA/'ENDA'/
C +++++
CQ2E
CQ2E            TYPE 12 DATA
CQ2E
        NDAM = 0
CBR        DO 790 I=1,10
C        WRITE(*,*)' MNUDAM=',MNUDAM
C        PAUSE
        DO 790 I=1,MNUDAM
C//     READ(NI,1601) (DATA(I,J),J=1,13)
C1601   FORMAT(2A4,A2,5X,F5.0,9F6.0)
        READ(NI,1601) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,7)
C        WRITE(*,*) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,7)
C        PAUSE
 1601   FORMAT (3A4,A2,5X,F5.0,6F6.0)
C///    IF(DATA(I,1) - ENDA) 791,792,791
C        WRITE(*,*)' ADATA(',I,')=',ADATA(I,1)
        IF (ADATA(I,1) .EQ. ENDA) GO TO 792
C +++++
C791     IDAM = RDATA(I,1) + 0.001
        IDAM = RDATA(I,1) + 0.001
C +++++
        IRCH = RDATA(I,2) + 0.001
        IELE = RDATA(I,3) + 0.001
C        write(*,*)' ICLORD(',IRCH,',',IELE,')=',ICLORD(IRCH,IELE)
        IOR = ICLORD(IRCH,IELE)
        JDAM(IOR) = IDAM
        ADAM(IDAM) = RDATA(I,4)
        BDAM(IDAM) = RDATA(I,5)
        FDAM(IDAM) = RDATA(I,6)
        HDAM(IDAM) = RDATA(I,7)
      IF(METRIC.NE.0) HDAM(IDAM) = HDAM(IDAM)*3.2808
        NDAM = NDAM + 1
790     CONTINUE
792     IF(ILIST.NE.0) WRITE(NJ,793)
793     FORMAT(1H0,10X,'$$$ DATA TYPE 12 (DAM CHARACTERISTICS) $$$'//
     1 32X,'DAM   RCH   ELE    ADAM    BDAM    FDAM    HDAM'/)
        II = I
C//     IF(ILIST.NE.0) WRITE(NJ,794) ((DATA(I,J),J=1,11),I=1,II)
        IF (ILIST .EQ. 0) GO TO 888
        DO 799 I = 1, II
        WRITE(NJ,794) (ADATA(I,J),J=1,4),(RDATA(I,J),J=1,7)
799     CONTINUE
794     FORMAT(10X,3A4,A2,7X,3F6.0,4F8.2)
C + + + + + + + + + + +
C
888   RETURN
      END
      SUBROUTINE IND13
C + + + + + + + + + +
C
C     THIS SUBROUTINE READS DATA TYPE 13 FOR A QUAL2E SIMULATION.
C
C + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
      CHARACTER*4       ADATA(ML,6),ENDA
      DIMENSION         RDATA(ML,8)
      DATA ENDA/'ENDA'/
C
C      INITIALIZATIONS
C
      TEMPLB = 0.0
      DOLB = 0.0
      BODLB = 0.0
      CONSLB(1) = 0.0
      CONSLB(2) = 0.0
      CONSLB(3) = 0.0
      ANCLB = 0.0
      COLILB = 0.0
      ALGLB = 0.0
      CNH2LB = 0.0
      CNH3LB = 0.0
      CNO2LB = 0.0
      CNO3LB = 0.0
      PORGLB = 0.0
      PHOSLB = 0.0
C
      I=1
      READ(NI,1800) (ADATA(I,J),J=1,6),(RDATA(I,J),J=1,8)
1800  FORMAT(6A4,8F7.0)
      IF(ILIST.EQ.0) GO TO 1805
      WRITE(NJ,1801)
1801  FORMAT(1H0,10X,'$$$ DATA TYPE 13 (DOWNSTREAM BOUNDARY CONDI',
     1'TIONS-1) $$$'/)
      WRITE(NJ,1802)
1802  FORMAT(15X,'CARD TYPE',15X,'TEMP',7X,'D.O.',6X,'BOD',7X,'CM-1',
     16X,'CM-2',6X,'CM-3',7X,'ANC',6X,'COLI'/)
1805  CONTINUE
C
      IF(ADATA(I,1).EQ.ENDA.AND.LBFLG.EQ.1) GO TO 1810
      IF(ADATA(I,1).EQ.ENDA.AND.LBFLG.NE.1) GO TO 1815
      GO TO 1820
1810  NERROR = 1
      WRITE(NJ,1812)
1812  FORMAT(/5X,'**** ERROR - DOWNSTREAM BOUNDARY IS CONSTRAINED',
     1' (LBFLG=1),'/10X,'BUT BOUNDARY DATA TYPE 13 ARE NOT SUP',
     2'PLIED ****'/)
1815  IF(ILIST.NE.0) WRITE(NJ,1831) (ADATA(I,J),J=1,6)
      GO TO 1850
1820  IF(LBFLG.EQ.0) GO TO 1830
      TEMPLB    = RDATA(I,1)
      DOLB      = RDATA(I,2)
      BODLB     = RDATA(I,3)
      CONSLB(1) = RDATA(I,4)
      CONSLB(2) = RDATA(I,5)
      CONSLB(3) = RDATA(I,6)
      ANCLB     = RDATA(I,7)
      COLILB    = RDATA(I,8)
      IF(ILIST.NE.0) WRITE(NJ,1825) (ADATA(I,J),J=1,6),
     *                              (RDATA(I,J),J=1,8)
1825  FORMAT(10X,6A4,8F10.2)
      IF(METRIC.NE.0) TEMPLB = TEMPLB*1.8 + 32.0
      GO TO 1840
1830  IF(ILIST.NE.0) WRITE(NJ,1831) (ADATA(I,J),J=1,6)
1831  FORMAT(10X,6A4,5X,'DOWNSTREAM BOUNDARY CONCENTRATIONS ARE',
     1' UNCONSTRAINED')
1840  I=2
      READ(NI,1800) (ADATA(I,J),J=1,6),(RDATA(I,J),J=1,8)
      IF (ADATA(I,1).EQ.ENDA) GO TO 1845
      NERROR = 1
      WRITE(NJ,1842)
1842  FORMAT(/5X,'****ERROR - ENDATA13 CARD MISSING ****'/)
      GO TO 1850
1845  IF(ILIST.NE.0) WRITE(NJ,1825) (ADATA(I,J),J=1,6)
1850  CONTINUE
C
C
      I=1
      READ(NI,1800) (ADATA(I,J),J=1,6),(RDATA(I,J),J=1,8)
      IF(ILIST.EQ.0) GO TO 1855
      WRITE(NJ,1851)
1851  FORMAT(1H0,10X,'$$$ DATA TYPE 13A (DOWNSTREAM BOUNDARY CON',
     1'DITIONS-2) $$$'/)
      WRITE(NJ,1852)
1852  FORMAT(15X,'CARD TYPE',15X,'CHL-A',5X,'ORG-N',5X,'NH3-N',5X,
     1'NO2-N',5X,'NH3-N',5X,'ORG-P',5X,'DIS-P'/)
1855  CONTINUE
      IF(ADATA(I,1).EQ.ENDA.AND.LBFLG.EQ.1) GO TO 1860
      IF(ADATA(I,1).EQ.ENDA.AND.LBFLG.NE.1) GO TO 1865
      GO TO 1870
1860  NERROR=1
      WRITE(NJ,1862)
1862  FORMAT(/5X,'**** ERROR - DOWNSTREAM BOUNDARY IS CONSTRIANED',
     1' (LBFLG=1),'/10X,'BUT BOUNDARY DATA TYPE 13A ARE NOT',
     2' SUPPLIED ****'/)
1865  IF(ILIST.NE.0) WRITE(NJ,1831) (ADATA(I,J),J=1,6)
      GO TO 1899
1870  IF(LBFLG.EQ.0) GO TO 1880
      ALGLB  = RDATA(I,1)
      CNH2LB = RDATA(I,2)
      CNH3LB = RDATA(I,3)
      CNO2LB = RDATA(I,4)
      CNO3LB = RDATA(I,5)
      PORGLB = RDATA(I,6)
      PHOSLB = RDATA(I,7)
      IF(ILIST.NE.0) WRITE(NJ,1825) (ADATA(I,J),J=1,6),
     *                              (RDATA(I,J),J=1,7)
C3.0      IF(MODOPT(4).GT.0) ALGLB = ALGLB/ALPHAO(NREACH)
      GO TO 1890
1880  IF(ILIST.NE.0) WRITE(NJ,1831) (ADATA(I,J),J=1,6)
1890  I=2
      READ(NI,1800) (ADATA(I,J),J=1,6),(RDATA(I,J),J=1,8)
      IF (ADATA(I,1).EQ.ENDA) GO TO 1895
      NERROR=1
      WRITE(NJ,1892)
1892  FORMAT(/5X/'**** ERROR - ENDATA13A CARD MISSING ****'/)
      GO TO 1899
1895  IF(ILIST.NE.0) WRITE(NJ,1825) (ADATA(I,J),J=1,6)
1899  CONTINUE
C
      RETURN
      END
      SUBROUTINE HYDRAU
C
C                             HYDRAU PERFORMS A HYDROLOGIC BALANCE ON
C                             THE SYSTEM BASED ON CONTINUITY. IT
C                             COMPUTES THE FLOW, VELOCITY, VOLUME,
C                             DEPTH, AND DISPERSION COEFFICIENT FOR
C                             EVERY ELEMENT IN THE SYSTEM.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C
CTGC      WRITE(*,*)'ENTER HYDRAU'
CC
CCC
CCC             NCASI Commentary, HYDRAU - SECTION A. (QUAL2 Step 1-0)
CCC                     A. Initialize constants in the system.
CCC
      NHW=0
      NWS=0
      IJUNC=0
CCC
CCC             NCASI Commentary, HYDRAU - SECTION B. (QUAL2 Step 2-0)
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
      QR=QI(I)/CNCELR
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      IFL=IFLAG(I,J)
CC
CC              Insert a dummy DO loop index, ICHAN, to avoid the
CC               index modification error message during compilation.
CC              Then swap ICHAN for I in the CALL CHANL statements.
CC
      ICHAN = I
CC
      GO TO (101,102,102,103,102,104,104), IFL
CCC
CCC             NCASI Commentary, HYDRAU - SECTION C. (QUAL2 Step 2-1)
CCC                     C. Hydraulics for Type 1 element.
CCC
  101 NHW=NHW+1
      FLOW(IOR)=HWFLOW(NHW)+QR
      IF(FLOW(IOR).LE.0.0) GO TO 150
      CALL CHANL(ICHAN,HWFLOW(NHW),VHW(NHW),DEPHW(NHW),IOR)
      DLHW(NHW)=3.82*DISKO(I)*CMANN(I)*VHW(NHW)*DEPHW(NHW)**0.833
      CALL CHANL(ICHAN,FLOW(IOR),VEL(IOR),DEPTH(IOR),IOR)
      DTOVCL(IOR)=DT2ODX/(HWFLOW(NHW)/VHW(NHW)+FLOW(IOR)/VEL(IOR))
      GO TO 105
CCC
CCC             NCASI Commentary, HYDRAU - SECTION D. (QUAL2 Step 2-2)
CCC                     D. Hydraulics for Type 2, 3, and 5
CCC                         elements.
CCC
  102 FLOW(IOR)=FLOW(IOR-1)+QR
      IF(FLOW(IOR).LE.0.0) GO TO 150
      CALL CHANL(ICHAN,FLOW(IOR),VEL(IOR),DEPTH(IOR),IOR)
      DTOVCL(IOR)=DT2ODX/(FLOW(IOR-1)/VEL(IOR-1)+FLOW(IOR)/VEL(IOR))
      GO TO 105
CCC
CCC             NCASI Commentary, HYDRAU - SECTION E. (QUAL2 Step 2-3)
CCC                     E. Hydraulics for Type 4 element.
CCC
  103 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
      FLOW(IOR)=FLOW(IOR-1)+FLOW(NN)+QR
      IF(FLOW(IOR).LE.0.0) GO TO 150
      CALL CHANL(ICHAN,FLOW(IOR),VEL(IOR),DEPTH(IOR),IOR)
CC
CC              Change definition of DTOVCL coefficient to reflect
CC               the average over three adjoining elements.
CC
      DT3ODX = 1.5*DT2ODX
CC
      DTOVCL(IOR)=DT3ODX/(FLOW(IOR-1)/VEL(IOR-1)+FLOW(IOR)/VEL(IOR)+
     *            FLOW(NN)/VEL(NN))
CC
      GO TO 105
CCC
CCC             NCASI Commentary, HYDRAU - SECTION F. (QUAL2 Step 2-4)
CCC                     F. Hydraulics for Type 6 and 7 elements.
CCC
  104 NWS=NWS+1
      FLOW(IOR)=FLOW(IOR-1)+WSFLOW(NWS)+QR
      IF(FLOW(IOR).LE.0.0) GO TO 150
      CALL CHANL(ICHAN,FLOW(IOR),VEL(IOR),DEPTH(IOR),IOR)
      DTOVCL(IOR)=DT2ODX/(FLOW(IOR-1)/VEL(IOR-1)+FLOW(IOR)/VEL(IOR))
  105 CONTINUE
      DL(IOR)=3.82*DISKO(I)*CMANN(I)*VEL(IOR)*DEPTH(IOR)**0.833
CCC
CCC             NCASI Commentary, HYDRAU - SECTION G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
      GO TO 175
150   WRITE(NJ,155) IOR
155   FORMAT(//'  NEGATIVE FLOW COMPUTED IN ELEMENT',
     1 I5,', EXECUTION TERMINATED'/
     2 /6X,'ELEMENT',7X,'FLOW'/)
      DO 160 K=1,IOR
160   WRITE(NJ,161) K,FLOW(K)
161   FORMAT(6X,I5,4X,F10.3)
C//   CALL EXIT
      STOP
175   CONTINUE
CCC
CCC             NCASI Commentary, HYDRAU - SECTION H.
CCC                     H. Return to MAIN.
CCC
CTGC      WRITE(*,*)'EXIT HYDRAU'
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE CHANL(J,Q,VELO,DPTH,K)
C
C                  THIS SUBROUTINE RETURNS VELOCITY AND DEPTH
C                  USING   THE NEWTON RAPHSON TECHNIQUE WHEN
C                  TRAP-CHANNEL DATA IS INPUT OR
C                  ALPHA'S AND BETA'S OTHERWISE
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

CC
CCC
CCC             NCASI Commentary, CHANL - Section B.
CCC                     B. Test for a dry channel (no flow).
CCC
C +++++
C      IF(Q.NE.0.0)GO TO 340
      IF(ABS(Q).GT.R0MIN) GO TO 340
C +++++
      VELO=0.
      DPTH=0
CCC
CCC                     B.1 Return to HYDRAU.
CCC
      RETURN
  340 CONTINUE
CCC
CCC             NCASI Commentary, CHANL - Section C.
CCC                     C. Test for trapezoidal cross sections.
CCC
CCC                     C.2 Calculate velocity and depth from
CCC                          correlations with flow.
CCC
      IF(ITRAP.EQ.1)GO TO 350
      VELO=COEFQV(J)*Q**EXPOQV(J)
      DPTH=COEFQH(J)*Q**EXPOQH(J)
      TRVTM(K) = DELX/(VELO*86400.)
      XAREA(K) = Q/VELO
      VOLSEG(K) = Q*DELX/(VELO)
      EWIDTH(K) = Q/(VELO*DPTH)
      BAREA(K) = (EWIDTH(K) + 2.*DPTH)*DELX
CCC
CCC                     C.2c Return to HYDRAU.
CCC
      RETURN
  350 CONTINUE
CCC
CCC             NCASI Commentary, CHANL - Section D.
CCC                     D. Calculate velocity and depth for
CCC                         trapezoidal cross sections from
CCC                         Manning's equation using Newton's
CCC                         method.
CCC
CCC                     D.1 Set initial guesses for old and
CCC                          new depths.
CCC
      DEL=1.
      DELD=1.
      CONST=1.486/CMANN(J)*SQRT(SLOPE(J))
CCC
CCC                     D.3 Set up loop for iterative solution.
CCC
      DO 360 I=1,30
      AREA=0.5*(SS1(J)+SS2(J))*DEL**2+WIDTH(J)*DEL
      DAREA=(SS1(J)+SS2(J))*DEL+WIDTH(J)
      WETPER=SQRT(SS1(J)**2+1)*DEL+SQRT(SS2(J)**2+1)*DEL+WIDTH(J)
      DWETP=(SQRT(SS1(J)**2+1))+(SQRT(SS2(J)**2+1))
      FLW=CONST*((AREA**1.66667)/(WETPER**0.66667))
      F=FLW-Q
      DF=CONST*(((1.66667*AREA**0.6667*DAREA)*(WETPER**0.66667))
     1   -((AREA**1.66667)*0.66667*(WETPER**(-0.33333))*DWETP))/
     2   (WETPER**1.33333)
      DEL=DELD-F/DF
CCC
CCC                     D.4 Test for convergence.
CCC
      IF(ABS(F).LT.0.001*Q) GO TO 380
  360 DELD=DEL
      WRITE(NJ,1111)
 1111 FORMAT(1H ,32HTHERE IS NO CONVERGENCE IN CHANL)
CCC
CCC                     D.4b Return to HYDRAU.
CCC
      RETURN
  380 CONTINUE
      DPTH=DEL
      VELO=Q/AREA
      TRVTM(K) = DELX/(VELO*86400.)
      XAREA(K) = AREA
      VOLSEG(K) = AREA*DELX
      EWIDTH(K) = AREA/DPTH
      BAREA(K) = WETPER*DELX
CCC
CCC                     D.5b Return to HYDRAU.
CCC
      RETURN
      END
      SUBROUTINE TRIMAT
C
C                             TRIMAT COMPUTES THE COEFFICIENT MATRIX
C                             FOR THE IMPLICIT-FINITE-DIFFERENCE FORM
C                             OF THE ONE-DIMENSIONAL (ADVECTION +
C                             DISPERSION) TRANSPORT EQUATION.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, TRIMAT - Section A. (QUAL2 Step 1-0)
CCC                     A. Initialize counters.
CCC
CTGC      WRITE(*,*)'ENTER TRIMAT'
      NHW=0
      NWS=0
      IJUNC=0
CCC
CCC             NCASI Commentary, TRIMAT - Section B. (QUAL2 Step 2-0)
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      X(IOR) = 1.0
      IF (ISS.GT.0) X(IOR) = 0.0
      IFL=IFLAG(I,J)
      GO TO (101,102,102,103,104,102,102), IFL
CCC
CCC             NCASI Commentary, TRIMAT - Section C. (QUAL2 Step 2-1)
CCC                     C. Coefficients for Type 1 element.
CCC
  101 NHW=NHW+1
      A(IOR)=-DTODX2*DLHW(NHW)-HWFLOW(NHW)*DTOVCL(IOR)
      X(IOR)=X(IOR)+DTODX2*(DLHW(NHW)+DL(IOR))+FLOW(IOR)*DTOVCL(IOR)
      C(IOR)=-DTODX2*DL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TRIMAT - Section D. (QUAL2 Step 2-2)
CCC                     D. Coefficients for Type 2, 3, 6, and 7
CCC                         elements.
CCC
  102 A(IOR)=-DTODX2*DL(IOR-1)-FLOW(IOR-1)*DTOVCL(IOR)
      X(IOR)=X(IOR)+DTODX2*(DL(IOR-1)+DL(IOR))+FLOW(IOR)*DTOVCL(IOR)
      C(IOR)=-DTODX2*DL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TRIMAT - Section E. (QUAL2 Step 2-3)
CCC                     E. Coefficients for Type 4 element.
CCC
  103 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
      D(IJUNC)=-DTODX2*DL(NN)-FLOW(NN)*DTOVCL(IOR)
      A(IOR)=-DTODX2*DL(IOR-1)-FLOW(IOR-1)*DTOVCL(IOR)
CC
CC              Change weighting factor on DL(IOR) from 2.0 to 1.0
CC
      X(IOR)=X(IOR)+DTODX2*(DL(IOR-1)+DL(NN)+1.0*DL(IOR))+FLOW(IOR)*
     *       DTOVCL(IOR)
      C(IOR)=-DTODX2*DL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TRIMAT - Section F. (QUAL2 Step 2-4)
CCC                     F. Coefficients for Type 5 element.
CCC
  104 A(IOR)=-DTODX2*(DL(IOR-1)+DL(IOR))-FLOW(IOR-1)*DTOVCL(IOR)
      X(IOR)=X(IOR)+DTODX2*(DL(IOR-1)+DL(IOR))+FLOW(IOR)*DTOVCL(IOR)
      C(IOR)=0.
      IF(LBFLG.EQ.0) GO TO 100
      A(IOR) =-(DTOVCL(IOR)*FLOW(IOR-1)+DTODX2*DL(IOR-1))
      C(IOR)=-DTODX2*DL(IOR)
CCC
CCC             NCASI Commentary, TRIMAT - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, TRIMAT - Section H.
CCC                     H. Return to MAIN.
CCC
CTGC      WRITE(*,*)'EXIT TRIMAT'
      RETURN
      END




      SUBROUTINE TCALCS
C
C + + + + + + + + +
C
C      THIS SUBROUTINE PERFORMS TEMPERATURE ROUTING FOR A
C       QUAL2E SIMULATION.
C
C + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
      DIMENSION TJ1(MC)
C
C + + + + + + + + +
C
CTGC      WRITE(*,*)'ENTER TCALCS'
CQ2E
CQ2E            TEST IF TIME/ITERATION TO READ LCD
CQ2E
        IF(MODOPT(2).EQ.0.AND.MODOPT(4).EQ.0) GO TO 700
        IF(ISS.GT.0) GO TO 550
C +++++
C        IF(TRLCD.NE.0.0) GO TO 515
        IF(ABS(TRLCD).GT.R0MIN) GO TO 515
C +++++
        READ(NI2,510) SOLHR,CLOUD,DRYBLB,WETBLB,ATMPR,WIND
 510     FORMAT(30X,F10.0,5F8.0)
        IF(METRIC.EQ.0) GO TO 511
        SOLHR = SOLHR*3.685
        DRYBLB = DRYBLB*1.8 + 32.0
        WETBLB = WETBLB*1.8 + 32.0
        ATMPR = ATMPR*(29.9/1000.)
        WIND = WIND/0.3048
 511     CONTINUE
        WIND = WIND*.6818
        IF(ITEMP.EQ.0) GO TO 515
        SOLL = SOLHR/3.685
        WRITE(NJ,512) TIME,SOLHR,SOLL,CLOUD,DRYBLB,WETBLB,ATMPR,WIND
C1234567
 512     FORMAT(1H1,//'  READING LOCAL CLIMATOLOGICAL DATA:'//
     18X,'TIME STEP =  ',F10.3/
     28X,'SOLHR =  ',F10.3,' BTU/FT2-HR  (',F10.3,' LANGLEYS/HR)'/
     38X,'CLOUD =  ',F10.3/
     48X,'DYRBLB =  ',F10.3,'  DEG-F'/
     58X,'WETBLB =  ',F10.3,'  DEG-F'/
     68X,'ATMPR =  ',F10.3,'  IN-HG'/
     78X,'WIND =  ',F10.3,'  MILES/HR'///)
 515     TRLCD = TRLCD + D2LT
        IF(TRLCD.LT.2.9) GO TO 599
        TRLCD = 0.0
        GO TO 599
 550     IF(MODOPT(2).EQ.0) GO TO 700
C3.0
C3.0     REMOVE LCD READ FOR STEADY STATE (TO INDATA TYPE5A)
C3.0
 599     CONTINUE
CCC
CCC                     G.5 Temperature - Dynamic simulation.
CCC
      IF (MODOPT(2).EQ.0) GO TO 700
      NT=6
      IF (ISS.GT.0.) GO TO 7702
C3.0
      CALL HEATEX
C3.0
      CALL TEMPS
      CALL SOVMAT
      DO 800 I=1,NCELLS
      T(I)=Z(I)
  800 CONTINUE
      GO TO 700
CCC
CCC                     G.6 Temperature - Steady state simulation.
CCC
 7702 IF (NITER.GT.0) GO TO 700
C3.0
      IF(INTOUT.NE.2) GO TO 7703
C +++++
C7721  WRITE(NJ,7723)
      WRITE(NJ,7723)
C +++++
 7723  FORMAT(1H1)
C +++++
C7722  CONTINUE
      CONTINUE
C +++++
        WRITE(NJ,7711)
 7711    FORMAT(1H1,/2X,'STEADY STATE TEMPERATURE SIMULATION;',
     1' CONVERGENCE SUMMARY:'/2X,57('-')//
     124X,'NUMBER OF'/10X,'ITERATION   NONCONVERGENT'/
     224X,'ELEMENTS'/)
 7703 DO 7706 I=1,NCELLS
      TJ1(I)=(T(I)-35.)/5.
 7706 CONTINUE
C3.0
      IF(NITER.EQ.0) CALL HEATER
C3.0
      CALL TEMPSS
      CALL SOVMAT
      MM=0
      DO 7704 I=1,NCELLS
      T(I)=Z(I)
      TJ=(T(I)-35.)/5.
      M=TJ+1
      IF (JT(I).EQ.M.AND.M.GT.0.AND.M.LE.21) GO TO 7704
      IF (JT(I).NE.M.AND.ABS(TJ-TJ1(I)).LE.0.10) GO TO 7704
      MM=MM+1
 7704 CONTINUE
      NITER=NITER+1
C3.0
      IF(INTOUT.NE.2) GO TO 7707
      WRITE(NJ,7705) NITER,MM
 7705 FORMAT(12X,I4,11X,I4)
 7707  CONTINUE
C3.0
      IF (NITER.GT.10) STOP
      IF (MM.GT.0) GO TO 7703
CQ2E
CQ2E            ADD STEADY STATE TEMPERATURE OUTPUT SUMMARY
C3.0
      IF(INTOUT.NE.2) GO TO 700
      A1=0.0
      A2=0.0
      XCELLS = NCELLS
      DO 10 I=1,NREACH
      CNCELR = NCELRH(I)
      WT = CNCELR/XCELLS
      A1 = A1+ TSONET(I)*WT
      A2 = A2 + TDLH(I)*WT
 10    CONTINUE
      BASNET = A1
      BADLH = A2
      DO 12 L=1,24
      BATSUN(L) = 0.0
      A3 = 0.0
      DO 13 I=1,NREACH
      CNCELR = NCELRH(I)
      WT = CNCELR/XCELLS
 13    A3 = A3 + TSUN(I,L)*WT
      BATSUN(L) = A3
 12    CONTINUE
        TSLR = A1/3.685
        WRITE(NJ,7712) A1,TSLR,A2
 7712    FORMAT(//2X,'SUMMARY OF VALUES FOR STEADY STATE TEMPERATURE',
     1' CALCULATIONS (SUBROUTINE HEATER):'/2X,80('-'),//,
     18X,'DAILY NET SOLAR RADIATION = ',F11.3,
     2' BTU/FT-2',3X,'(',F9.3,' LANGLEYS)'/8X,'NUMBER OF',
     3' DAYLIGHT HOURS = ',F5.1///8X,'HOURLY VALUES OF SOLAR',
     4' RADIATION (BTU/FT-2)'/)
      IF(IFGRVT.EQ.0) GO TO 730
      WRITE(NJ,21) (J,J=1,24)
 21    FORMAT(//' RCH   DLH',4I4,16I5,4I4,3X,'TOTAL'/)
      DO 22 I=1,NREACH
 22    WRITE(NJ,23) I,TDLH(I),(TSUN(I,KT),KT=1,24),TSONET(I)
 23    FORMAT(I4,F6.1,4F4.0,16F5.0,4F4.0,F8.1)
      WRITE(NJ,24) BADLH,(BATSUN(L),L=1,24),BASNET
 24    FORMAT(//' AVG',F6.1,4F4.0,16F5.0,4F4.0,F8.1//)
      GO TO 700
 730   DO 7713 KH=1,8
      KH1 = KH+8
      KH2 = KH1+8
 7713  WRITE(NJ,7714) KH,BATSUN(KH),KH1,BATSUN(KH1),KH2,BATSUN(KH2)
 7714  FORMAT(10X,3(I5,F9.2,5X))
C3.0
C
C + + + + + + + +
C
 700   CONTINUE
C
C + + + + + + + +
C
CTGC      WRITE(*,*)'EXIT TCALCS'
      RETURN
      END





      SUBROUTINE QCALC1
C
C + + + + + + + +
C
C     THIS SUBROUTINE PERFORMS QUALITY CONSTITUENT ROUTING FOR
C      UNLINKED VARIABLES IN A QUAL2E SIMULATION.
C
C + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
CCC
CCC                     G.4 Conservative mineral.
CCC
C +++++
C700   IF (MODOPT(1).EQ.0) GO TO 703
      IF (MODOPT(1).EQ.0) GO TO 703
C  701 NT=3
      NT=3
C +++++
      DO 777 NC=1,NCS
      CALL CONSVT
      CALL SOVMAT
      NT=NT+1
      DO 808 I=1,NCELLS
      CONS(I,NC)=Z(I)
  808 CONTINUE
  777 CONTINUE
CCC
CCC                     G.7 Carbonaceous BOD.
CCC
  703 IF (MODOPT(3).EQ.0) GO TO 708
      NT = 7
      CALL BODS
      CALL SOVMAT
      DO 802 I=1,NCELLS
      BOD(I)=Z(I)
  802 CONTINUE
CCC
CCC                     G.12 Coliform.
CCC
  708 IF (MODOPT(8).EQ.0) GO TO 799
      NT = 14
      CALL COLIS
      CALL SOVMAT
      DO 807 I=1,NCELLS
      COLI(I) = Z(I)
  807 CONTINUE
CCC
CCC                     G.13 Arbitrary non-conservative.
CCC
799   IF(MODOPT(9).EQ.0) GO TO 7741
      NT=15
      CALL ANCS
      CALL SOVMAT
      DO 809 I=1,NCELLS
      ANC(I)=Z(I)
  809 CONTINUE
C + + + + + + + +
C
7741  CONTINUE
      RETURN
      END
      SUBROUTINE QCALC2
C
C + + + + + + + + +
C
C      THIS SUBROUTINE PERFORMS QUALITY CONSTITUENT ROUTING FOR
C       LINKED WATER QUALITY VARIABLES IN A QUAL2E SIMULATION.
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
      GO TO (7741,704,847,7070) ITCODE
CQ2E
CQ2E            STEADY STATE ITERATIONS
CQ2E
7741    CONTINUE
        IF(ISS.LE.0) GO TO 7044
        IF(MODOPT(4).EQ.0.AND.MODOPT(6).EQ.0.AND.MODOPT(7).
     1 EQ.0) GO TO 7044
      IF(MODOPT(4).EQ.0.AND.MODOPT(6).EQ.0.AND.NDAM.EQ.0) GO TO 7044
      IF(MODOPT(4).EQ.0.AND.KNITRF.GE.10..AND.MODOPT(7).EQ.0)
     * GO TO 7044
      IF(MODOPT(4).EQ.0.AND.KNITRF.GE.10..AND.NDAM.EQ.0) GO TO 7044
C3.0
      IF(INTOUT.EQ.2)  WRITE(NJ,7043)
7043    FORMAT(1H1//2X,'STEADY STATE ALGAE/NUTRIENT/DISSOLVED',
     1' OXYGEN SIMULATION; CONVERGENCE SUMMARY:'/2X,77('-')//
     1 52X,'NUMBER OF'/
     2 13X,'VARIABLE',14X,'ITERATION      NONCONVERGENT'/
     3 52X,'ELEMENTS'/)
7044    CONTINUE
CCC
CCC                     G.8 Algae (Chlorophyll a).
CCC
C +++++
C7040  IF (MODOPT(4).EQ.0) GO TO 705
      IF (MODOPT(4).EQ.0) GO TO 705
C +++++
C
C               INITIALIZE / COMPUTE  GROWTH RATES
C
        CALL GROW
        IPASS = 1
        DO 7041 I=1,NREACH
        NCELR = NCELRH(I)
        DO 7041 J=1,NCELR
        IOR = ICLORD(I,J)
7041    GROWTH(IOR) = Z(IOR)
704   IF(MODOPT(4).EQ.0) GO TO 705
      NT = 8
      CALL ALGAES
      CALL SOVMAT
      DO 804 I=1,NCELLS
      ALGAE(I) = Z(I)
      IF (ALGAE(I).GT.50.) ALGAE(I)=50.
      IF (ALGAE(I).LE.0.0) ALGAE(I)=0.00001
  804 CONTINUE
CCC
CCC                     G.9 Phospohrus.
CCC
  705 IF (MODOPT(5).EQ.0) GO TO 706
        NT=22
        CALL PORGS
        CALL SOVMAT
        DO 8050 I=1,NCELLS
        PORG(I) = Z(I)
8050    CONTINUE
      NT = 9
      CALL PO4S
      CALL SOVMAT
      DO 805 I=1,NCELLS
      PHOS(I) = Z(I)
  805 CONTINUE
CCC
CCC                     G.10 Nitrogens (Ammonia, Nitrite, and
CCC                           Nitrate).
CCC
  706 IF (MODOPT(6).EQ.0) GO TO 707
        NT=21
        CALL NH2S
        CALL SOVMAT
        DO 8060 I=1,NCELLS
        CNH2(I) = Z(I)
8060    CONTINUE
      NT = 10
CQ2E
CQ2E            NITRIFICATION INHIBITION AT LOW DO
CQ2E
        DO 846 I=1,NREACH
        NCELR = NCELRH(I)
        DO 846 J=1,NCELR
        IOR = ICLORD(I,J)
      CORDO(IOR) = 1.0
      IF(KNITRF.GE.10.) GO TO 8460
      EXPNIT = KNITRF*DO2(IOR)
      IF(EXPNIT.LT.10.) CORDO(IOR) = 1.-EXP(-EXPNIT)
8460  CONTINUE
        TC=0.556*(T(IOR)-68.0)
        KNH3(IOR) = CKNH3(I)*CORDO(IOR)*THETA(7)**TC
846     KNO2(IOR) = CKNO2(I)*CORDO(IOR)*THETA(9)**TC
847     CONTINUE
      CALL NH3S
      CALL SOVMAT
      DO 806 I=1,NCELLS
      CNH3(I) = Z(I)
  806 CONTINUE
      NT = 11
      CALL NO2S
      CALL SOVMAT
      DO 816 I=1,NCELLS
      CNO2(I) = Z(I)
  816 CONTINUE
      NT = 12
      CALL NO3S
      CALL SOVMAT
      DO 826 I=1,NCELLS
      CNO3(I) = Z(I)
  826 CONTINUE
CCC
CCC                     G.11 Dissolved oxygen.
CCC
  707 IF (MODOPT(7).EQ.0) GO TO 7999
      NT = 13
7070  CONTINUE
      CALL DOS
      CALL SOVMAT
      DO 803 I=1,NCELLS
      DO2(I)=Z(I)
  803 CONTINUE
 7999 CONTINUE
C
C + + + + + ++ +
C
      RETURN
      END
      SUBROUTINE SSCONV
C
C + + + + + + + + + +
C
C      THIS SUBROUTINE CHECKS FOR CONVERGENCE OF STEADY
C       STATE SOLUTIONS.
C
C + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CCDM
CCDM    ADD NON-CONVERGENCE OUTPUT AIDS
CCDM
      DIMENSION NCONEL(MC)
      DATA NCONEL/MC*0/
CCDM
CCC
CCC             NCASI Commentary, MAIN - Section H.
CCC                     H. Adjustment/check of algal GROWth rate,
CCC                         N, and P concentrations in steady
CCC                          state simulations.
CCC
CCC                     H.1 Test whether algae are being simulated.
CCC
C3.0
      EPSI = 0.001
      RELAX=0.7
CQ2E
 9990 IF (MODOPT(4)) 1001,1001,9992
CCC
CCC                     H.2 Initialize and increment counters.
CCC
 9992 NUM = 0
      ITER = ITER + 1
CCC
CCC                     H.3 Set up loop on reaches and elements.
CCC
      CALL GROW
      DO 9994 JJ=1,NREACH
      NCELR=NCELRH(JJ)
      DO 9994 KK=1,NCELR
      I=ICLORD(JJ,KK)
      DG = Z(I) - GROWTH(I)
      OLD = EPSI*ABS(GROWTH(I))
CCDM
CCDM      INSERT CONVERGENCE OVERRIDE AS GROWTH RATE GOES TO ZERO
CCDM         CONVERGENCE DELTA = 0.0001
CCDM
      IF(GROWTH(I).LT.0.10) OLD = 0.0001
CCDM
        IF(ABS(DG).GT.OLD) NUM = NUM + 1
CCDM
        IF(ABS(DG).GT.OLD) NCONEL(NUM) = I
CCDM
        GROWTH(I) = GROWTH(I) + RELAX*DG
 9994 CONTINUE
CCC
CCC                     H.11 Test for convergence in all elements.
CCC
C3.0
      IF(INTOUT.EQ.2)  WRITE(NJ,7045) ITER,NUM
7045    FORMAT(3X,'ALGAE GROWTH RATE',15X,I3,13X,I4)
        IF (NUM) 1001,1001,9699
C -> ->
C9699   IF(ITER.LT.TMAX) GO TO 704
C -> ->
9699    IF(ITER.GE.TMAX) GO TO 10
      ITCODE = 2
      RETURN
10    CONTINUE
C -> ->
CCDM
CCDM     MODIFY PRINT FOR DEBUGGING NON-CONVERGED SIMULATION
CCDM
        WRITE(NJ,1003) NUM,TMAX
1003    FORMAT(//'  SS ALGAE NOT CONVERGED FOR ',I5,' ELEMENTS,'/
     1 '  AFTER',F6.1,' ITERATIONS.')
      WRITE(NJ,2003) (NCONEL(KEL),KEL=1,NUM)
2003    FORMAT(//'   ELEMENTS NOT CONVERGED'/
     1 15(6X,20I6/)/
     2 40X,' ######  END EXECUTION  ######'/)
      CALL WRPT3A(NPAGE)
      CALL WRPT3B(NPAGE)
CCDM
C/      CALL EXIT
        STOP
CQ2E
CQ2E            TEST FOR NITRIFICATION INHIBITION CONVERGENCE
CQ2E
1001    CONTINUE
        IF(MODOPT(6).EQ.0) GO TO 620
      IF(KNITRF.GE.10.) GO TO 620
        ITERN = ITERN + 1
        JJ=0
        DO 602 I=1,NREACH
        NCELR = NCELRH(I)
        DO 602 J=1,NCELR
        IOR = ICLORD(I,J)
      DOCOR = 1.0
      EXPNIT = KNITRF*DO2(IOR)
      IF(EXPNIT.LT.10.) DOCOR=1.-EXP(-EXPNIT)
        DIFF = CORDO(IOR)-DOCOR
      OLD = EPSI*ABS(CORDO(IOR))
C3.0
C3.0     INSERT CONVERGENCE OVERRIDE AS CORDO GOES TO ZERO
CCDM            DELTA = 0.0001 ON CORDO
C3.0
      IF(CORDO(IOR).LT.0.1) OLD = 0.0001
C3.0
        IF(ABS(DIFF).GT.OLD) JJ=JJ+1
CCDM
       IF(ABS(DIFF).GT.OLD) NCONEL(JJ) = IOR
CCDM
        CORDO(IOR) = CORDO(IOR)-RELAX*DIFF
        TC=0.556*(T(IOR)-68.0)
        KNH3(IOR) = CORDO(IOR)*CKNH3(I)*THETA(7)**TC
        KNO2(IOR) = CORDO(IOR)*CKNO2(I)*THETA(9)**TC
602     CONTINUE
C3.0
      IF(INTOUT.EQ.2)  WRITE(NJ,7046) ITERN,JJ
7046    FORMAT(5X,'NITRIFICATION INHIBITION',9X,I3,14X,I4)
        IF(JJ.LE.0) GO TO 620
C -> ->
C       IF(ITERN.LT.TMAX) GO TO 847
C -> ->
      IF(ITERN.GE.TMAX) GO TO 20
      ITCODE = 3
      RETURN
20    CONTINUE
C -> ->
CCDM
CCDM     MODIFY PRINT OUT FOR DEBUGGING NON-CONVERGED SIMULATION
CCDM
        WRITE(NJ,615) JJ,TMAX
615     FORMAT(//'  SS NITRIFICATION INHIBITION NOT CONVERGED FOR ',
     1 I5,' ELEMENTS'/'  AFTER',F6.1,' ITERATIONS.')
       WRITE(NJ,1615) (NCONEL(KEL),KEL = 1,JJ)
1615   FORMAT(//'   ELEMENTS NOT CONVERGED'/
     1 15(6X,20I6/)//
     2  40X,'######  END EXECUTION ######'/)
      CALL WRPT3A(NPAGE)
      CALL WRPT3B(NPAGE)
CCDM
C/      CALL EXIT
        STOP
620     CONTINUE
CQ2E
CQ2E            DO CONVERGENCE
CQ2E
        IF(MODOPT(7).EQ.0.OR.NDAM.EQ.0) GO TO 640
        ITERO = ITERO + 1
        JJJ = 0
        CALL DOS
        CALL SOVMAT
        DO 630 I=1,NCELLS
        DIFF = DO2(I) - Z(I)
      OLD = EPSI*ABS(DO2(I))
CCDM
CCDM    INSERT CONVERGENCE OVERRIDE AS DO GOES TO ZERO
CCDM           DELTA = 0.0001  ON DO
CCDM
      IF(DO2(I).LT.0.10)  OLD = 0.0001
CCDM
        IF(ABS(DIFF).GT.OLD) JJJ = JJJ + 1
CCDM
      IF(ABS(DIFF).GT.OLD) NCONEL(JJJ) = I
CCDM
        DO2(I) = Z(I)
630     CONTINUE
C3.0
      IF(INTOUT.EQ.2)  WRITE(NJ,631) ITERO,JJJ
631     FORMAT(7X,'DISSOLVED OXYGEN (DAMS)',11X,I3,15X,I4)
        IF(JJJ.LE.0) GO TO 640
C -> ->
C       IF(ITERO.LT.TMAX) GO TO 7070
C -> ->
      IF(ITERO.GE.TMAX) GO TO 30
      ITCODE=4
      RETURN
30    CONTINUE
C -> ->
CCDM
CCDM      MODIFY PRINT OUT FOR DEBUGGING NON-CONVERGED SIMULATION
CCDM
        WRITE(NJ,632) JJJ,TMAX
632     FORMAT(//'SS DISSOLVED OXYGEN NOT CONVERGED FOR ',I5,
     1 ' ELEMENTS,'/'  AFTER',F6.1,' ITERATIONS.')
      WRITE(NJ,1632) (NCONEL(KEL),KEL=1,JJJ)
1632   FORMAT(//'   ELEMENTS NOT CONVERGED'/
     1 15(6X,20I6/)//
     2 40X,'######  END EXECUTION  ######'/)
      CALL WRPT3A(NPAGE)
      CALL WRPT3B(NPAGE)
CCDM
C/      CALL EXIT
        STOP
640     CONTINUE
      JTER = JTER + 1
      ITCODE = 2
C
C + + + + + + +
C
      RETURN
      END
C
C + + + + + + +
      SUBROUTINE TEMPS
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C       INCLUDE 'ARRAYS.VAR'
C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
CCC
CCC             NCASI Commentary, TEMPS - Section A.
CCC                     A. Initialize counters and constants.
CCC
      NHW=0
      NWS=0
      IJUNC=0
      RHOCP=62.4
CCC
CCC             NCASI Commentary, TEMPS - Section B.
CCC                     B. Perform heat flux calculations.
CCC
C3P0    Move call to HEATEX to TCALCS.
C     CALL HEATEX
CCC
CCC             NCASI Commentary, TEMPS - Section C.
CCC                     C. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + +  + + + + +
      TPIJI = QI(I)/CNCELR*TI(I)
      TPIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      TPIJI = 0.0
      TPIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, TEMPS - Section D.
CCC                     D. Initialize diagonal and known terms.
CCC
      B(IOR)=X(IOR)-TPIJO*DTOVCL(IOR)
      IFL=IFLAG(I,J)
      GO TO (101,102,102,104,109,103,105), IFL
CCC
CCC             NCASI Commentary, TEMPS - Section E.
CCC                     E. Heat balance for Type 1 element.
CCC
  101 NHW=NHW+1
      ADEPTH=0.5*(DEPHW(NHW)+DEPTH(IOR))
      REACT=HSNET(IOR)/(RHOCP*ADEPTH)
      S(IOR)=T(IOR)+REACT+TPIJI*DTOVCL(IOR)-A(IOR)*HWTEMP(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPS - Section F.
CCC                     F. Heat balance for Type 2, 3, and 5
CCC                         elements.
CCC
  102 ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=HSNET(IOR)/(RHOCP*ADEPTH)
      S(IOR)=T(IOR)+REACT+TPIJI*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPS - Section G.
CCC                     G. Heat balance for Type 6 element.
CCC
  103 NWS=NWS+1
      ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=HSNET(IOR)/(RHOCP*ADEPTH)
      S(IOR)=T(IOR)+REACT+(TPIJI+WSFLOW(NWS)*WSTEMP(NWS))*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPS - Section H.
CCC                     H. Heat balance for Type 4 element.
CCC
  104 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
      ADEPTH=0.25*(DEPTH(IOR-1)+DEPTH(NN)+2.0*DEPTH(IOR))
      REACT=HSNET(IOR)/(RHOCP*ADEPTH)
      S(IOR)=T(IOR)+REACT+TPIJI*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPS - Section I.
CCC                     I. Heat balance for Type 7 element.
CCC
  105 NWS=NWS+1
      ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=HSNET(IOR)/(RHOCP*ADEPTH)
      S(IOR)=T(IOR)+REACT+(TPIJI)*DTOVCL(IOR)
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 102
      T(IOR) = T(IOR) - C(IOR)*TEMPLB
      GO TO 102
CCC
CCC             NCASI Commentary, TEMPS - Section J.
CCC                     J. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, TEMPS - Section K.
CCC                     K. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE HEATEX
C
C                             HEATEX COMPUTES THE NET AMOUNT OF HEAT
C                             RADIATION FLUX BEING TRANSFERRED ACROSS
C                             THE AIR-WATER INTERFACE BASED ON AN
C                             ENERGY BUDGET WHICH CONSIDERS SOLAR
C                             RADIATION, ATMOSPHERIC RADIATION, BACK
C                             RADIATION, CONDUCTION, AND EVAPORATION.
CC
C  UPDATED 6/84 T.WILSON FOR IBM - TO CORRECT APARRENT TYPO
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C       INCLUDE 'ARRAYS.VAR'
C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C       INCLUDE 'WASTLD.VAR'
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

CC
C
CCC
CCC             NCASI Commentary, HEATEX Section A. (QUAL2 Step 1-0)
CCC                     A. Compute and/or define required constants.
CCC
C
C +++++
C      IF (TOFDAY.NE.0.0) GO TO 77
      IF (ABS(TOFDAY).GT.R0MIN) GO TO 77
C +++++
C
C      PI=3.141628           <---Moved to BLOCK DATA subroutine.
      CON1=2.0*PI/365.0
      CON2=PI/180.0*LAT
      CON3=180.0/PI
      CON4=23.45*PI/180.0
      CON5=PI/12.0
      CON6=12.0/PI
      DELTSL=(LLM-LSM)/15.0
      SOLCON=438.0
      ELEXP=EXP(-ELEV/2532.0)
CCC
CCC             NCASI Commentary, HEATEX Section B. (QUAL2 Step 2-0)
CCC                     B. Begin computations  for calculating the
CCC                         net solar radiation term.
CCC
CCC                     B.1 Test for beginning of a new day.
CCC
CDD    Branch for TOFDAY moved to same location as in HEATER.
C
CCC
CCC                     B.1a Calculate seasonal and daily position
CCC                           of the sun relative to the location
CCC                           of the basin on the earth's
CCC                           surface. (QUAL2 Step 2-1)
CCC
      REARTH=1.0+0.017*COS(CON1*(186.0-DAYOFY))
      DECLIN=CON4*COS(CON1*(172.0-DAYOFY))
      RR=REARTH**2
      EQTIME=0.000121-0.12319*SIN(CON1*(DAYOFY-1.0)-0.07014)
     *       -0.16549*SIN(2.0*CON1*(DAYOFY-1.0)+0.3088)
      DECLON=ABS(DECLIN)
CC
CC              Replace TAN function with SIN/COS.
CC
        TANA = SIN(CON2)/COS(CON2)
        TANB = SIN(DECLON)/COS(DECLON)
        ACS = TANA*TANB
CC
C +++++
C      IF (ACS.EQ.0.0) GO TO 8
      IF (ABS(ACS).LT.R0MIN) GO TO 8
C +++++
      XX=SQRT(1.0-ACS*ACS)
      XX=XX/ACS
C ->-> CHANGED ATAN(X) TO ATAN(XX) TO CORRECT APPARENT TYPO. <-<-
C ->->    -T.WILSON 6/15/84   <-<-
C      ACS=ATAN(X)
      ACS=ATAN(XX)
      IF (DECLIN.GT.0.0) ACS=PI-ACS
      GO TO 9
    8 ACS=PI/2.0
    9 CONTINUE
CCC
CCC                     B.1a Calculate the standard time of
CCC                           sunrise (STR) and sunset (STS).
CCC                           (QUAL2 Step 2-2)
CCC
C      IF (TOFDAY.NE.0.0) GO TO 77
C
      STR=12.0-CON6*ACS+DELTSL
      STS=24.0-STR+2.0*DELTSL
      STB=0.0
      STE=STB+D2LT
      GO TO 78
CCC
CCC                     B.2 Increment the variables that define the
CCC                          time of the beginning(STB) and the
CCC                          end (STE) of the time interval.
CCC
   77 STB=STB+D2LT
      STE=STB+D2LT
   78 CONTINUE
CCC
CCC                     B.3 Test if time to read in local
CCC                          climatological data. (QUAL2 Step 2-3)
CCC
C +++++
C      IF (ABS(TRLCD).GT.RP1MIN) GO TO 82
      IF (TRLCD.NE.1.0) GO TO 82
C +++++
CCC
CCC                     B.7 Compute vapor pressures (VPWB and
CCC                          VPAIR), dew point (DEWPT), AND
CCC                          dampening effect of clouds (CNS
CCC                          and CNL). (QUAL2 Step 2-4)
CCC
      VPWB=0.1001*EXP(0.03*WETBLB)-0.0837
      VPAIR=VPWB-0.000367*ATMPR*(DRYBLB-WETBLB)
     *     *(1.0+(WETBLB-32.0)/1571.0)
      DEWPT=ALOG((VPAIR+0.0837)/0.1001)/0.03
      CS=1.0-0.65*CLOUD**2
      IF (CLOUD.GT.0.9) CS=0.50
      CNL=CLOUD*10.0+1.0
      NL=CNL
82    CONTINUE
      IF (STS.LE.STB.OR.STR.GE.STE) GO TO 35
      IF(STR.GT.STB.AND.STR.LT.STE) GO TO 41
      IF (STS.LT.STE.AND.STS.GT.STB) GO TO 42
CCC
CCC             NCASI Commentary, HEATEX Section C. (QUAL2 Step 2-5)
CCC                     C. Continue with calculations for solar
CCC                         radiation.
CCC
CCC                     C.1 Calculate hour angles (TB and TE).
CCC
      TB=STB-12.0-DELTSL+EQTIME
      TE=STE-12.0-DELTSL+EQTIME
      GO TO 43
   41 TB=STR-12.0-DELTSL+EQTIME
      TE=STE-12.0-DELTSL+EQTIME
      GO TO 43
   42 TB=STB-12.0-DELTSL+EQTIME
      TE=STS-12.0-DELTSL+EQTIME
   43 CONTINUE
      TALT=(TB+TE)/2.0
CCC
CCC                     C.2 Compute amount of clear sky, solar
CCC                          radiation(SOLAR), and altitude of
CCC                          the sun (ALPHA). (QUAL2 Step 2-6)
CCC
      SOLAR=SOLCON/RR*(SIN(CON2)*SIN(DECLIN)*(TE-TB)+CON6*COS(CON2)*
     *      COS(DECLIN)*(SIN(CON5*TE)-SIN(CON5*TB)))
      ALPHA=SIN(CON2)*SIN(DECLIN)+COS(CON2)*COS(DECLIN)*COS(CON5*TALT)
C +++++
C      IF (ABS(ALPHA).LT.RP1MIN) GO TO 4
      IF (ABS(ALPHA).EQ.1.0) GO TO 4
C +++++
      Y=SQRT(1.0-ALPHA*ALPHA)
      Y=ALPHA/Y
      ALPHA=ATAN(Y)
      GO TO 5
C +++++
C    4  IF (ABS(ALPHA).LT.RP1MIN) GO TO 6
    4 IF (ALPHA.EQ.-1.0) GO TO 6
C +++++
      ALPHA=PI/2.0
      GO TO 5
    6 ALPHA=-PI/2.0
    5 CONTINUE
      IF (ALPHA.LT.0.01) GO TO 35
CCC
CCC                     C.3 Compute absorption and scattering due
CCC                          to atmospheric conditions. (QUAL2
CCC                          Step 2-7)
CCC
      PWC=0.00614*EXP(0.0489*DEWPT)
      OAM=ELEXP/(SIN(ALPHA)+0.15*(ALPHA*CON3+3.885)**(-1.253))
      A1=EXP(-(0.465+0.0408*PWC)*(0.129+0.171*EXP(-0.880*OAM))*OAM)
      A2=EXP(-(0.465+0.0408*PWC)*(0.179+0.421*EXP(-0.721*OAM))*OAM)
CCC
CCC                     C.4 Compute reflectivity coefficient (RS).
CCC                          (QUAL2 Step 2-8)
CCC
      GO TO (30,31,31,31,31,31,32,32,32,32,33), NL
   30 AR=1.18
      BR=-0.77
      GO TO 34
   31 AR=2.20
      BR=-0.97
      GO TO 34
   32 AR=0.95
      BR=-0.75
      GO TO 34
   33 AR=0.35
      BR=-0.45
   34 CONTINUE
      RS=AR*(CON3*ALPHA)**BR
CC
CC              Add test for RS greater than 1.0.
CC
        IF(RS.GE.1.0) GO TO 35
CC
CCC
CCC                     C.5 Compute atmospheric transmission term (ATC).
CCC
      ATC=(A2+0.5*(1.0-A1-DAT))/(1.0-0.5*RS*(1.0-A1+DAT))
CCC
CCC                     C.6 Compute net solar radiaiont for the time
CCC                          interval delta t. (QUAL2 Step 2-9)
CCC
      TSOLHR=SOLAR*ATC*CS*(1.0-RS)
      GO TO 36
   35 TSOLHR=0.0
   36 CONTINUE
      CLC=1.0+0.17*CLOUD**2
CCC
CCC             NCASI Commentary, HEATEX Section D. (QUAL2 Step 3-0)
CCC                     D. Compute heat fluxes from other terms.
CCC
CCC                     D.1 Long wave atmospheric radiation (HA).
CCC
      HA=0.97*1.73E-09*2.89E-06*(DRYBLB+460.0)**6*CLC*D2LT
CCC
CCC                     D.2 Water surface back radiation (HB).
CCC
      DO 70 I=1,NREACH
      NCELR=NCELRH(I)
      DO 70 J=1,NCELR
      IOR=ICLORD(I,J)
      VPW=0.1001*EXP(0.03*T(IOR))-0.0837
      HB=0.97*1.73E-09*(T(IOR)+460.0)**4*D2LT
CCC
CCC                     D.3 Evaporation (HE).
CCC
      EVAP=62.4*(AE+BE*WIND)
      HE=EVAP*(VPW-VPAIR)*(1084.0-0.5*T(IOR))*D2LT
CCC
CCC                     D.4 Conduction (HC).
CCC
      HC=0.01*EVAP*(DRYBLB-T(IOR))*(1084.0-0.5*T(IOR))*D2LT
CCC
CCC             NCASI Commentary, HEATEX Section E.
CCC                     E. Compute net heat flux from all sources.
CCC
      HSNET(IOR)=TSOLHR+HA-HB+HC-HE
   70 CONTINUE
      TOFDAY=TOFDAY+D2LT
      IF(ITEMP.EQ.0) GO TO 71
      TSLR = TSOLHR/3.685
      WRITE(NJ,93) TOFDAY,TSOLHR,TSLR
93    FORMAT(///'  DYNAMIC TEMPERATURE SIMULATION:'/
     18X,'TIME OF DAY =  ',F10.3/
     28X,'HOURLY SOLAR RADIATION =  ',F8.3,' BTU/FT-2
     3 OR ',F9.3,' LANGLEYS')
71    CONTINUE
CCC
CCC             NCASI Commentary, HEATEX Section F.
CCC                     F. Test for beginning of a new day.
CCC
      IF (TOFDAY.LT.23.9) GO TO 85
      TOFDAY=0.0
      DAYOFY=DAYOFY+1.0
   85 CONTINUE
CCC
CCC             NCASI Commentary, HEATEX Section G.
CCC                     G. Return to TEMPS.
CCC
      RETURN
      END
      SUBROUTINE TEMPSS
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
      REAL MU,LAMBDA
CCC
CCC             NCASI Commentary, TEMPSS - Section B.
CCC                     B. Test iteration counter, NITER.
CCC
C3P0     Move the call to HEATER to TCALCS.
C     IF (NITER.EQ.0) CALL HEATER
CCC
CCC             NCASI Commentary, TEMPSS - Section C.
CCC                     C. Initialize counters and constants.
CCC
      NHW=0
      NWS=0
      IJUNC=0
      RHOCP=62.4
CCC
CCC             NCASI Commentary, TEMPSS - Section D.
CCC                     D. Set up loop on number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
CCC
CCC                     D.1 Calculate the terms needed for heat
CCC                          balance based on the average local
CCC                          climatological data and the average
CCC                          net solar radiation.
CCC
      VPWB=0.1001*EXP(0.03*RCHTWB(I))-0.0837
      VPAIR=VPWB
     *     -0.000367*RCHATM(I)*(RCHTDB(I)-RCHTWB(I))*
     *       (1.0+(RCHTWB(I)-32.0)/1571.0)
      CLC=1.0+0.17*RCHCLD(I)**2
      HA=4.85E-15*(RCHTDB(I)+460.0)**6*CLC
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      TPIJI = QI(I)/CNCELR*TI(I)
      TPIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      TPIJI = 0.0
      TPIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      IFL=IFLAG(I,J)
CCC
CCC             NCASI Commentary, TEMPSS - Section E.
CCC                     E. Initialize and/or compute known terms.
CCC
      S(IOR)=0.
      TJ=(T(IOR)-35.)/5.
      M=TJ+1
      JT(IOR)=M
      HLAT=1084.-0.5*T(IOR)
      B1=RHOCP*HLAT*(AE+BE*RCHWND(I))
CC
CC              Change constant in statements for B2 and B3 from
CC                0.3342 to 0.01 because the units of P and T
CC                are (in HG) and (deg-F).
CC
      B2=BETA1(M)+0.01
      LAMBDA=BETA2(M)+B1*B2
      B3=ALFA1(M)-VPAIR-0.01*RCHTDB(I)
CC
CC              Redefine HS because the units of RCHSOL(I) are
CC               already BTU/ft2-hr as calculated in HEATER.
CC
      HS =  RCHSOL(I)
CC
      MU=HS+HA-ALFA2(M)-B1*B3
      GO TO (101,102,102,104,109,103,105), IFL
CCC
CCC             NCASI Commentary, TEMPSS - Section F.
CCC                     F. Heat balance for Type 1 element.
CCC
  101 NHW=NHW+1
      ADEPTH=0.5*(DEPHW(NHW)+DEPTH(IOR))
      REACT=MU*D2LT/(RHOCP*ADEPTH)
      ST=TPIJI*DTOVCL(IOR)-A(IOR)*HWTEMP(NHW)
      S(IOR)=S(IOR)+REACT+ST
      B(IOR)=X(IOR)-TPIJO*DTOVCL(IOR)+LAMBDA*D2LT/(RHOCP*ADEPTH)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPSS - Section G.
CCC                     G. Heat balance for Type 2, 3, and 5
CCC                         elements.
CCC
  102 ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=MU*D2LT/(RHOCP*ADEPTH)
      S(IOR)=S(IOR)+REACT+TPIJI*DTOVCL(IOR)
      B(IOR)=X(IOR)-TPIJO*DTOVCL(IOR)+LAMBDA*D2LT/(RHOCP*ADEPTH)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPSS - Section H.
CCC                     H. Heat balance for Type 6 element.
CCC
  103 NWS=NWS+1
      ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=MU*D2LT/(RHOCP*ADEPTH)
      ST=(TPIJI+WSFLOW(NWS)*WSTEMP(NWS))*DTOVCL(IOR)
      S(IOR)=S(IOR)+REACT+ST
      B(IOR)=X(IOR)-TPIJO*DTOVCL(IOR)+LAMBDA*D2LT/(RHOCP*ADEPTH)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPSS - Section I.
CCC                     I. Heat balance for Type 4 element.
CCC
  104 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
      ADEPTH=0.25*(DEPTH(IOR-1)+DEPTH(NN)+2.*DEPTH(IOR))
      REACT=MU*D2LT/(RHOCP*ADEPTH)
      S(IOR)=S(IOR)+REACT+TPIJI*DTOVCL(IOR)
      B(IOR)=X(IOR)-TPIJO*DTOVCL(IOR)+LAMBDA*D2LT/(RHOCP*ADEPTH)
      GO TO 100
CCC
CCC             NCASI Commentary, TEMPSS - Section J.
CCC                     J. Heat balance for Type 7 element.
CCC
  105 NWS=NWS+1
      ADEPTH=0.5*(DEPTH(IOR-1)+DEPTH(IOR))
      REACT=MU*D2LT/(RHOCP*ADEPTH)
      S(IOR)=S(IOR)+REACT+TPIJI*DTOVCL(IOR)
      BT=(TPIJO+WSFLOW(NWS))*DTOVCL(IOR)
      B(IOR)=X(IOR)+LAMBDA*D2LT/(RHOCP*ADEPTH)-BT
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 102
      S(IOR) = S(IOR)-C(IOR)*TEMPLB
      GO TO 102
CCC
CCC             NCASI Commentary, TEMPSS - Section K.
CCC                     K. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, TEMPSS - Section L.
CCC                     L. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE HEATER
C
C                             HEATEX COMPUTES THE NET AMOUNT OF HEAT
C                             RADIATION FLUX BEING TRANSFERRED ACROSS
C                             THE AIR-WATER INTERFACE BASED ON AN
C                             ENERGY BUDGET WHICH CONSIDERS SOLAR
C                             RADIATION, ATMOSPHERIC RADIATION, BACK
C                             RADIATION, CONDUCTION, AND EVAPORATION.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C       INCLUDE 'WASTLD.VAR'
C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

CC
CCC
CCC             NCASI Commentary, HEATER - Section B. (QUAL2 Step 1-0)
CCC                     B. Compute and/or define required
CCC                         constants.
CCC
C      PI=3.141628         <---Moved to BLOCK DATA subroutine.
      CON1=2.0*PI/365.0
      CON2=PI/180.0*LAT
      CON3=180.0/PI
      CON4=23.45*PI/180.0
      CON5=PI/12.0
      CON6=12.0/PI
      DELTSL=(LLM-LSM)/15.0
      SOLCON=438.0
CCC             NCASI Commentary, HEATER - Section C. (QUAL2 Step 2-0)
CCC                     C. Begin computations for calculating
CCC                         the net solar radiation term.
CCC
CCC                     C.1a Calculate seasonal and daily
CCC                           position of sun relative to the
CCC                           location of the basin on the earth's
CCC                           surface. (QUAL2 Step 2-1)
CCC
      REARTH=1.0+0.017*COS(CON1*(186.0-DAYOFY))
      DECLIN=CON4*COS(CON1*(172.0-DAYOFY))
      RR=REARTH**2
      EQTIME=0.000121-0.12319*SIN(CON1*(DAYOFY-1.0)-0.07014)
     *       -0.16549*SIN(2.0*CON1*(DAYOFY-1.0)+0.3088)
      DECLON=ABS(DECLIN)
CC
CC              Change TAN to  SIN/COS.
CC
        TANA = SIN(CON2)/COS(CON2)
        TANB = SIN(DECLON)/COS(DECLON)
        ACS = TANA*TANB
CC
C +++++
C      IF (ACS.EQ.0.0) GO TO 8
      IF (ABS(ACS).LT.R0MIN) GO TO 8
C +++++
      XX=SQRT(1.0-ACS*ACS)
      XX=XX/ACS
      ACS=ATAN(XX)
      IF (DECLIN.GT.0.0) ACS=PI-ACS
      GO TO 9
    8 ACS=PI/2.0
    9 CONTINUE
CCC
CCC                     C.1a Calculate the standard time of
CCC                           sunrise(STR) and sunset (STS).
CCC                           (QUAL2 Step 2-2)
CCC
CQT
      DO 100 I=1,NREACH
      TSONET(I) = 0.0
      ELEXP = EXP(-RCHELV(I)/2532.0)
CCC
CCC                     C.8 Compute vapor pressures (VPWB and
CCC                          VPAIR), dew point (DEWPT), and
CCC                          dampening effect of clouds (CS and
CCC                          CNL). (QUAL2 Step 2-4)
CCC
      VPWB=0.1001*EXP(0.03*RCHTWB(I))-0.0837
      VPAIR=VPWB-0.000367*RCHATM(I)*(RCHTDB(I)-RCHTWB(I))
     *     *(1.0+(RCHTWB(I)-32.0)/1571.0)
      DEWPT=ALOG((VPAIR+0.0837)/0.1001)/0.03
      CS=1.0-0.65*RCHCLD(I)**2
      IF (RCHCLD(I).GT.0.9) CS=0.50
      CNL=RCHCLD(I)*10.0+1.0
      NL=CNL
C +++++
C      IF (TOFDAY.NE.0.0) GO TO 77
      IF (TOFDAY.GT.R0MIN) GO TO 77
C +++++
CQT
      STR=12.0-CON6*ACS+DELTSL
      STS=24.0-STR+2.0*DELTSL
      STB=0.0
      STE=STB+D2LT
      GO TO 78
CCC
CCC                     C.2 Increment the variables that define
CCC                          the time of the beginning (STB)
CCC                          and end (STE) of the time interval.
CCC
   77 STB=STB+D2LT
      STE=STB+D2LT
   78 CONTINUE
        KT = TOFDAY + 1.0
C +++++
C   82 CONTINUE
      CONTINUE
C +++++
      IF (STS.LE.STB.OR.STR.GE.STE) GO TO 35
      IF(STR.GT.STB.AND.STR.LT.STE) GO TO 41
      IF (STS.LT.STE.AND.STS.GT.STB) GO TO 42
CCC
CCC             NCASI Commentary, HEATER - Section D.
CCC                     D. Continue with calculations for the
CCC                         net solar radiation.
CCC
CCC                     D.1 Calculate hour angles (TB and TE).
CCC                          (QUAL2 Step 2-5)
CCC
      TB=STB-12.0-DELTSL+EQTIME
      TE=STE-12.0-DELTSL+EQTIME
      GO TO 43
   41 TB=STR-12.0-DELTSL+EQTIME
      TE=STE-12.0-DELTSL+EQTIME
      GO TO 43
   42 TB=STB-12.0-DELTSL+EQTIME
      TE=STS-12.0-DELTSL+EQTIME
   43 CONTINUE
      TALT=(TB+TE)/2.0
CCC
CCC                     D.2 Compute amount of clear sky, solar
CCC                          radiation (SOLAR), and altitude of
CCC                          the sun (ALPHA). (QUAL2 Step 2-6)
CCC
      SOLAR=SOLCON/RR*(SIN(CON2)*SIN(DECLIN)*(TE-TB)+CON6*COS(CON2)*
     *      COS(DECLIN)*(SIN(CON5*TE)-SIN(CON5*TB)))
      ALPHA=SIN(CON2)*SIN(DECLIN)+COS(CON2)*COS(DECLIN)*COS(CON5*TALT)
C +++++
C      IF (ABS(ALPHA).LT.RP1MIN) GO TO 4
      IF (ABS(ALPHA).EQ.1.0) GO TO 4
C +++++
      Y=SQRT(1.0-ALPHA*ALPHA)
      Y=ALPHA/Y
      ALPHA=ATAN(Y)
      GO TO 5
C +++++
C    4  IF (ABS(ALPHA).LT.RP1MIN) GO TO 6
    4 IF (ALPHA.EQ.-1.0) GO TO 6
C +++++
      ALPHA=PI/2.0
      GO TO 5
    6 ALPHA=-PI/2.0
    5 CONTINUE
      IF (ALPHA.LT.0.01) GO TO 35
CCC
CCC                     D.3 Compute absorption and scattering due
CCC                          to atmospheric conditions. (QUAL2
CCC                          Step 2-7)
CCC
      PWC=0.00614*EXP(0.0489*DEWPT)
      OAM=ELEXP/(SIN(ALPHA)+0.15*(ALPHA*CON3+3.885)**(-1.253))
      A1=EXP(-(0.465+0.0408*PWC)*(0.129+0.171*EXP(-0.880*OAM))*OAM)
      A2=EXP(-(0.465+0.0408*PWC)*(0.179+0.421*EXP(-0.721*OAM))*OAM)
CCC
CCC                     D.4 Compute reflectivity coefficient, RS.
CCC                          (QUAL2 Step 2-8)
CCC
CCC
CCC                     D.5 Compute atmospheric transmission term.
CCC
      GO TO (30,31,31,31,31,31,32,32,32,32,33), NL
   30 AR=1.18
      BR=-0.77
      GO TO 34
   31 AR=2.20
      BR=-0.97
      GO TO 34
   32 AR=0.95
      BR=-0.75
      GO TO 34
   33 AR=0.35
      BR=-0.45
   34 CONTINUE
      RS=AR*(CON3*ALPHA)**BR
CC
CC              Add a test for reflectivity greater than 1.0
CC
        IF(RS.GE.1.0) GO TO 35
CC
      ATC=(A2+0.5*(1.0-A1-RCHDAC(I)))/(1.0-0.5*RS*(1.0-A1+RCHDAC(I)))
CCC
CCC             NCASI Commentary, HEATER - Section E. (QUAL2 Step 2-9)
CCC                     E. Calculation of average net daily
CCC                         solar radiation.
CCC
CC
CC          NCASI Modifications.
CC              Calculate hourly solar radiation as TSUN(I,KT) and
CC          accumulate values in TSONET.  Continue through the
CC          24 hours of the day.  Then write the average value
CC          (TSONET/24.) into the RCHSOL(I) array.
CC
      TSUN(I,KT)=SOLAR*ATC*CS*(1.0-RS)*RCHSAT(I)
      GO TO 36
   35 TSUN(I,KT)=0.0
   36 CONTINUE
        TSONET(I) = TSONET(I) + TSUN(I,KT)
      TOFDAY=TOFDAY+D2LT
      IF (TOFDAY.LT.23.9) GO TO 77
      TOFDAY=0.
      RCHSOL(I) = TSONET(I)/24.0
        TDLH(I) = STS-STR
100   CONTINUE
CCC
CCC             NCASI Commentary, HEATER - Section F.
CCC                     F. Return to TEMPSS.
CCC
      RETURN
      END
      SUBROUTINE CONSVT
C
C                             CONSVT PERFORMS A CONSERVATIVE MINERAL
C                             BALANCE FOR EACH COMPUTATIONAL ELEMENT
C                             IN THE SYSTEM.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, CONSVT - Section A.
CCC                     A. Initialize counters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, CONSVT - Section B.
CCC                     B. Set up loop on number of reaches
CCC                          and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      CONSJI = QI(I)/CNCELR*CONSI(I,NC)
      CONSJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      CONSJI = 0.0
      CONSJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC                     B.5 Initialize diagonal and known terms.
CCC
      B(IOR)=X(IOR)-CONSJO*DTOVCL(IOR)
      S(IOR)=CONS(IOR,NC)
      IF(ISS.GT.1) S(IOR)=0.0
      S(IOR)=S(IOR)+CONSJI*DTOVCL(IOR)
CCC
CCC                     B.8 For Type 2, 3, 4 and 5 elements
CCC                          the conservative mineral balance
CCC                          is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, CONSVT - Section C.
CCC                     C. Mineral balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWCONS(NHW,NC)
      GO TO 100
CCC
CCC             NCASI Commentary, CONSVT - Section D.
CCC                     D. Mineral balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSCONS(NWS,NC)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, CONSVT - Section E.
CCC                     E. Mineral balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*CONSLB(NC)
CCC
CCC             NCASI Commentary, CONSVT - Section F.
CCC                     F. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, CONSVT - Section G.
CCC                     G. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE BODS
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
CCC
CCC             NCASI Commentary, BODS - Section A.
CCC                     A. Initialize counters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, BODS - Section B.
CCC                     B. Set up loop on number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      BODIJI=QI(I)/CNCELR*BODI(I)
      BODIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      BODIJI = 0.0
      BODIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, BODS - Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      TC=0.556*(T(IOR)-68.0)
      K1(IOR)=CK1(I)*THETA(1)**TC
      K3(IOR) = CK3(I)*THETA(2)**TC
      REACT=D1LT*(K1(IOR)+K3(IOR))
      B(IOR)=X(IOR)+REACT-BODIJO*DTOVCL(IOR)
      S(IOR)=BOD(IOR)
      IF(ISS.GT.1) S(IOR)=0.0
      S(IOR)=S(IOR)+BODIJI*DTOVCL(IOR)
CCC
CCC
CCC                     C.9 For Type 2, 3, 4 and 5 elements
CCC                          the BOD balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, BODS - Section D.
CCC                     D. BOD balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWBOD(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, BODS - Section E.
CCC                     E. BOD balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSBOD(NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, BODS - Section F.
CCC                     F. BOD balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*BODLB
CCC
CCC             NCASI Commentary, BODS - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, BODS - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE COLIS
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CCC
CCC             NCASI Commentary, COLIS Section A.
CCC                     A.  Initialize counters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, COLIS Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + +
      COLIJI=QI(I)/CNCELR*COLIR(I)
      COLIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      COLIJI = 0.0
      COLIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, COLIS Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      TC=0.556*(T(IOR)-68.0)
      K5(IOR)=CK5(I)*THETA(16)**TC
      REACT=D1LT*K5(IOR)
      B(IOR)=X(IOR)+REACT-COLIJO*DTOVCL(IOR)
      S(IOR)=COLI(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+COLIJI*DTOVCL(IOR)
CCC
CCC                     C.8 For Type 2, 3, 4 and 5 elements
CCC                          the coliform balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, COLIS Section D.
CCC                     D. Coliform balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWCOLI(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, COLIS Section E.
CCC                     E. Coliform balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSCOLI(NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, COLIS Section F.
CCC                     F. Coliform balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*COLILB
CCC
CCC             NCASI Commentary, COLIS Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CC
CCC
CCC             NCASI Commentary, COLIS Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE ANCS
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, ANCS - Section A.
CCC                     A. Initialize counters.
CCC
      NHW=0
      NWS=0
        FACT = 1.0/(28.3*86400.0)
CCC
CCC             NCASI Commentary, ANCS - Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + +
      ANCIJI=QI(I)/CNCELR*ANCI(I)
      ANCIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      ANCIJI = 0.0
      ANCIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, ANCS - Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      TC=0.556*(T(IOR)-68.0)
      KANC(IOR)=CKANC(I)*THETA(17)**TC
      STANC(IOR) = SETANC(I)*THETA(18)**TC
      B(IOR) = X(IOR)-ANCIJO*DTOVCL(IOR)+(KANC(IOR)+STANC(IOR))*D1LT
      SRANC(IOR) = (SRCANC(I)*THETA(19)**TC)
      S1 = ANCIJI + SRANC(IOR)*BAREA(IOR)*FACT
      S(IOR)=ANC(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR) = S(IOR) + S1*DTOVCL(IOR)
CCC
CCC                     C.8 For Type 2, 3, 4, and 5 elements the
CCC                          non-conservative balance is now
CCC                          complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, ANCS - Section D.
CCC                     D. Non-conservative balance for Type 1
CCC                         element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWANC(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, ANCS - Section E.
CCC                     E. Non-conservative balance for Type 6
CCC                         element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSANC(NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, ANCS - Section F.
CCC                     F. Non-conservative balance for Type 7
CCC                         element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*ANCLB
CCC
CCC             NCASI Commentary, ANCS - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, ANCS - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE GROW
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C               TEST DYNAMIC/SS SIMULATION
        IF(ISS.GT.0) GO TO 40
C               TEST FOR DYNAMIC TEMPERATURE
        IF(MODOPT(2).GT.0) GO TO 20
C               SOLAR VALUES FROM LCD
        RF = SOLHR/CKL
        AF = 1.0
        GO TO 99
C               SOLAR VALUES FROM HEATEX
20      SUNNY = 0
        IF(TSOLHR.GT.0.0) SUNNY = TFACT*TSOLHR
        RF = SUNNY/CKL
        AF = 1.0
C +++++
C        IF(ITEMP.EQ.0.OR.TPRINT.EQ.PTIME) GO TO 25
        RDIF=TPRINT-PTIME
        IF(ITEMP.EQ.0.OR.ABS(RDIF).LT.R0MIN) GO TO 25
C +++++
        SUNNZ = SUNNY/3.685
        WRITE(NJ,26) TOFDAY,SUNNY,SUNNZ
26      FORMAT(/'  DYNAMIC ALGAE SIMULATION:'/
     18X,'TIME OF DAY =  ',F10.3/
     28X,'SOLAR RADIATION FOR ALGAE =  ',F10.3,
     2' BTU/FT-2   OR',F10.3,' LANGLEYS'///)
25      CONTINUE
        GO TO 99
C       INITIALIZATION FOR STEADY STATE LIGHT PARAMETERS
40      IF(IPASS.GT.0) GO TO 99
C               TEST LIGHT AVERAGING OPTION
        GO TO (50,60,70,80) LAVOPT
C               LAVOPT = 1
50      SONET = TFACT*BASNET
        DLH = BADLH
        AF = AFACT*DLH/24.0
        RF = SONET/(DLH*CKL)
        GO TO 99
C               LAVOPT = 2
60      AF = AFACT*DLH/24.0
        RF = SONET/(DLH*CKL)
        GO TO 99
C               LAVOPT = 3
70      NDLH = 0
        DO 75 L=1,24
        SUN(L) = 0.0
        IF(BATSUN(L).GT.0.0) SUN(L) = TFACT*BATSUN(L)
        R(L) = SUN(L)/CKL
        IF(SUN(L).LE.0.00) GO TO 75
        NDLH = NDLH + 1
75      CONTINUE
        AF = 1.0
        GO TO 99
C               LAVOPT = 4
80      NDLH = DLH
        SOAVE = SONET/NDLH
        DHR = FLOAT(NDLH) + 1.0
        DO 82 L=1,NDLH
        XL = L
        ARG = 2.0*3.14159*XL/DHR
        SUN(L) = SOAVE*(1.0-COS(ARG))
82      R(L) = SUN(L)/CKL
        J=NDLH + 1
        DO 84 L=J,24
        SUN(L) = 0.0
84      R(L) = 0.0
        AF = 1.0
99      CONTINUE
C               LOOP ON REACHES
        DO 200 I=1,NREACH
        NCELR = NCELRH(I)
        DO 200 J=1,NCELR
        IOR = ICLORD(I,J)
        AGFL(IOR) = 1.0
        AGFP(IOR) = 1.0
        AGFN(IOR) = 1.0
        TC = 0.556*(T(IOR)-68.0)
C               LIGHT EXTINCTION COEFF
        CHLA=ALPHAO(I)*ALGAE(IOR)
        EXTC(IOR) = EXCOEF(I)+EXALG1*CHLA+EXALG2*(CHLA**.667)
        EF = EXTC(IOR)
        ZF = DEPTH(IOR)
C
C +++++
C
        IF(ABS(-EF*ZF).GE.88.0) THEN
          XF=0.0
        ELSE
          XF = EXP(-EF*ZF)
        ENDIF
C
C +++++
C
      DENOM = EF*ZF
C               TEST FOR DYNAMIC SS SIMULATION
        IF(ISS.GT.0) GO TO 110
        CALL LIGHT(LFNOPT,AF,RF,XF,DENOM,FL)
        AGFL(IOR) = FL
        GO TO 160
110     GO TO (120,120,130,130) LAVOPT
120     CALL LIGHT(LFNOPT,AF,RF,XF,DENOM,FL)
        AGFL(IOR) = FL
        GO TO 160
130     SUM = 0.0
        DO 135 L=1,24
        RF = R(L)
        CALL LIGHT(LFNOPT,AF,RF,XF,DENOM,FL)
135     SUM = SUM + FL
        AGFL(IOR) = SUM/24.0
C               NUTRIENT GROWTH FACTORS
160     CPE = PHOS(IOR)
        IF(MODOPT(5).NE.0) AGFP(IOR) = CPE/(CKP+CPE)
        CNE =  CNO3(IOR)+CNH3(IOR)
        IF(MODOPT(6).NE.0) AGFN(IOR) = CNE/(CKN+CNE)
C               GROWTH ATTENUATION OPTION
        GO TO (170,180,190) LGROPT
C               LGROPT = 1
170     FNPL = AGFL(IOR)*AGFP(IOR)*AGFN(IOR)
        GO TO 195
C               LGROPT = 2
180     FNP = AMIN1(AGFN(IOR),AGFP(IOR))
        FNPL = AGFL(IOR)*FNP
        GO TO 195
C               LGROPT = 3
190     FNP = (1.0/AGFN(IOR))+(1.0/AGFP(IOR))
        FNPL = AGFL(IOR)*2.0/FNP
C               TEMPERATURE ADJUST
195     Z(IOR) = GROMAX*FNPL*(THETA(13)**TC)
200     CONTINUE
        RETURN
        END
      SUBROUTINE LIGHT(LFNOPT,AF,RF,XF,DENOM,FL)
        GO TO (10,20,30) LFNOPT
C               HALF SATURATION FUNCTION
10      AN = 1.0+RF
        AD = 1.0+RF*XF
        AL = ALOG(AN/AD)
        FL = (AF*AL)/DENOM
        RETURN
C               SMITH FUNCTION
20      AN = RF+SQRT(1.0+RF*RF)
        AD = (RF*XF)+SQRT(1.0+RF*RF*XF*XF)
        AL = ALOG(AN/AD)
        FL = (AF*AL)/DENOM
        RETURN
C               STEELE FUNCTION
30      AN = EXP(-XF*RF) - EXP(-RF)
        FL = 2.718*AF*AN/DENOM
        RETURN
        END
       SUBROUTINE ALGAES
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, ALGAES - Section A.
CCC                     A. Initialize cunters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, ALGAES - Section B.
CCC                     B. Read in solar radiation data, if
CCC                         required.
CCC
CCC
CCC             NCASI Commentary, ALGAES - Section C.
CCC                     C. Set up loop on number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      ALGIJI = QI(I)/CNCELR*ALGI(I)
      ALGIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      ALGIJI = 0.0
      ALGIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, ALGAES - Section D.
CCC                     D. Compute algal growth rates.
CCC
      TC = 0.556*(T(IOR)-68.0)
      RESPRR(IOR)=RESPRT*THETA(14)**TC
        AGYSET(IOR) = ALGSET(I)*THETA(15)**TC
      ALSINK=AGYSET(IOR)/DEPTH(IOR)
CCC
CCC             NCASI Commentary, ALGAES - Section E.
CCC
CCC                     E. Initialize diagonal and known terms.
CCC
      REACT=GROWTH(IOR)-RESPRR(IOR)-ALSINK
      B(IOR)=X(IOR)-ALGIJO*DTOVCL(IOR)-REACT*D1LT
      S(IOR)=ALGAE(IOR)
      IF(ISS.GT.1) S(IOR)=0.0
      S(IOR) = S(IOR)+ALGIJI*DTOVCL(IOR)
CCC
CCC                     E.6 For Type 2, 3, 4 and 5 elements
CCC                          the algae balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, ALGAES - Section F.
CCC                     F. Algal balance fo Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR) = S(IOR) - A(IOR)*HWALG(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, ALGAES - Section G.
CCC                     G. Algal balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR) = S(IOR) + WSFLOW(NWS)*WSALG(NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, ALGAES - Section H.
CCC                     H. Algal balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR) = B(IOR) - WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*ALGLB
CCC
CCC             NCASI Commentary, ALGAES - Section I.
CCC                     I. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, ALGAES - Section J.
CCC                     J. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE PORGS
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
C
C                            INITIALIZE COUNTERS
C
      NHW=0
      NWS=0
      FACT = 1.0 / (28.3 * 86400.0)
C
C                            LOOP THROUGH REACHES AND COMP. ELEMENTS
C
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + +
      PRGIJI=QI(I)/CNCELR*PORGI(I)
      PRGIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      PRGIJI = 0.0
      PRGIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
C
C                            INITIALIZE DIAGONAL AND KNOWN TERMS
C
      IF(MODOPT(4).EQ.0) ALGAE(IOR) = 0.1E-10
      TC=0.556*(T(IOR)-68.0)
      KPORG(IOR) = CKPORG(I)*THETA(10)**TC
      REACT = ALPHA2*RESPRR(IOR)*ALGAE(IOR)*D1LT
      STPORG(IOR) = SVPORG(I)*THETA(11)**TC
      B(IOR)=X(IOR)-PRGIJO*DTOVCL(IOR)+D1LT*(KPORG(IOR)+STPORG(IOR))
      S(IOR)=PORG(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+REACT+PRGIJI*DTOVCL(IOR)
      IFL=IFLAG(I,J)
C
C                            MODIFY DIAGONAL AND/OR KNOWN TERMS
C
      GO TO (101,100,100,100,109,103,104), IFL
C
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWPORG(NHW)
      GO TO 100
C
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSPORG(NWS)*DTOVCL(IOR)
      GO TO 100
C
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*PORGLB
  100 CONTINUE
      RETURN
      END
      SUBROUTINE PO4S
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, PO4S - Section A.
CCC                     A. Initialize counters and constants.
CCC
      NHW=0
      NWS=0
      FACT = 1.0 / (28.3 * 86400.0)
CCC
CCC             NCASI Commentary, PO4S - Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + +
      POSIJI = QI(I)/CNCELR*PHOSI(I)
      POSIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      POSIJI = 0.0
      POSIJO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, PO4S - Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      S(IOR)=PHOS(IOR)
      B(IOR)=X(IOR)-POSIJO*DTOVCL(IOR)
      IF(ISS.GT.0) S(IOR)=0.0
      TC = 0.556*(T(IOR)-68.0)
      SCPHOS(IOR) = SPHOS(I)*THETA(12)**TC
      PSORCE=SCPHOS(IOR)*BAREA(IOR)*DTOVCL(IOR) * FACT
      REACT = (PORG(IOR)*KPORG(IOR) - ALPHA2*GROWTH(IOR)
     1 *ALGAE(IOR))*D1LT
      S(IOR)=S(IOR)+POSIJI*DTOVCL(IOR)+REACT+PSORCE
CCC
CCC                     C.7 For Type 2, 3, 4, and 5 elements the
CCC                          phosphorus balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, PO4S - Section D.
CCC                     D.Phosphorus balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR) = S(IOR) - A(IOR)*HWPHOS(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, PO4S - Section E.
CCC                     E. Phosphorus balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR) = S(IOR) + WSFLOW(NWS)*WSPHOS(NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, PO4S - Section F.
CCC                     F. Phosphorus balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR) = B(IOR) - WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*PHOSLB
CCC
CCC             NCASI Commentary, PO4S - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, PO4S - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE NH2S
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
C
C                            INITIALIZE COUNTERS
C
      NHW=0
      NWS=0
      FACT = 1.0 / (28.3 * 86400.0)
C
C                            LOOP THROUGH REACHES AND COMP. ELEMENTS
C
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + + +
      CNH2JI=QI(I)/CNCELR*CNH2I(I)
      CNH2JO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      CNH2JI = 0.0
      CNH2JO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
C
C                            INITIALIZE DIAGONAL AND KNOWN TERMS
C
      IF(MODOPT(4).EQ.0) ALGAE(IOR) = 0.0
      TC=0.556*(T(IOR)-68.0)
      KNH2(IOR)=CKNH2(I)*THETA(5)**TC
      REACT = ALPHA1*RESPRR(IOR)*ALGAE(IOR)*D1LT
      SETNH2(IOR) = SVNH2(I)*THETA(6)**TC
      B(IOR)=X(IOR)-CNH2JO*DTOVCL(IOR)+D1LT*(KNH2(IOR) + SETNH2(IOR))
      S(IOR)=CNH2(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+REACT+CNH2JI*DTOVCL(IOR)
      IFL=IFLAG(I,J)
C
C                            MODIFY DIAGONAL AND/OR KNOWN TERMS
C
      GO TO (101,100,100,100,109,103,104), IFL
C
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWNH2(NHW)
      GO TO 100
C
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSNH2 (NWS)*DTOVCL(IOR)
      GO TO 100
C
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
C
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*CNH2LB
  100 CONTINUE
      RETURN
      END
      SUBROUTINE NH3S
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

CC
CCC
CCC             NCASI Commentary, NH3S - Section A.
CCC                     A. Initialize counters and constants.
CCC
      NHW=0
      NWS=0
      FACT = 1.0 / (28.3 * 86400.0)
CCC
CCC             NCASI Commentary, NH3S - Section B.
CCC                     B. Set up loop on number of reaches and
CCC                         elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      CNH3JI=QI(I)/CNCELR*CNH3I(I)
      CNH3JO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      CNH3JI = 0.0
      CNH3JO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, NH3S - Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      TC=0.556*(T(IOR)-68.0)
      SRCNH3(IOR) = SNH3(I)*THETA(8)**TC
      AMSRCE = SRCNH3(IOR)*BAREA(IOR)*DTOVCL(IOR)*FACT
      PRF(IOR) = (PREFN*CNH3(IOR))+((1.0-PREFN)*CNO3(IOR))
C +++++
C      IF(PRF(IOR).NE.0) PRF(IOR) = PREFN*CNH3(IOR)/PRF(IOR)
      RTEST=PRF(IOR)
      IF(ABS(RTEST).GT.R0MIN) PRF(IOR) = PREFN*CNH3(IOR)/PRF(IOR)
C +++++
      REACT = KNH2(IOR)*CNH2(IOR)*D1LT
      REACT = REACT - ALPHA1*GROWTH(IOR)*ALGAE(IOR)*PRF(IOR)*D1LT
      B(IOR)=X(IOR)-CNH3JO*DTOVCL(IOR)+D1LT*KNH3(IOR)
      S(IOR)=CNH3(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+REACT+CNH3JI*DTOVCL(IOR) + AMSRCE
CCC
CCC                     C.8 For Type 2, 3,4, and 5 elements
CCC                         the ammonia balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, NH3S - Section D.
CCC                     D. Ammonia balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWNH3(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, NH3S - Section E.
CCC                     E. Ammonia balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSNH3 (NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, NH3S - Section F.
CCC                     F. Ammonia balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*CNH3LB
CCC
CCC             NCASI Commentary, NH3S - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, NH3S - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE NO2S
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C       INCLUDE 'ARRAYS.VAR'
C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, NO2S - Section A.
CCC                     A. Initialize counters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, NO2S - Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + +
      CNO2JI=QI(I)/CNCELR*CNO2I(I)
      CNO2JO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      CNO2JI = 0.0
      CNO2JO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, NO2S - Section C.
CCC                     C. Initialize known terms and diagonal.
CCC
      TC=0.556*(T(IOR)-68.0)
      REACT=D1LT*KNH3(IOR)*CNH3(IOR)
      B(IOR)=X(IOR)-CNO2JO*DTOVCL(IOR)+D1LT*KNO2(IOR)
      S(IOR)=CNO2(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+REACT+CNO2JI*DTOVCL(IOR)
CCC
CCC                     C.8 For Type 2, 3, 4, and 5 elements
CCC                          the nitrite balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, NO2S - Section D.
CCC                     D. Nitrite balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWNO2(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, NO2S - Section E.
CCC                     E. Nitrite balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSNO2 (NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, NO2S - Section F.
CCC                     F. Nitrite balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*CNO2LB
CCC
CCC             NCASI Commentary, NO2S - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, NO2S - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE NO3S
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C       INCLUDE 'ARRAYS.VAR'
C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CCC
CCC             NCASI Commentary, NO3S - Section A.
CCC                     A. Initialize counters.
CCC
      NHW=0
      NWS=0
CCC
CCC             NCASI Commentary, NO3S - Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + +  +
      CNO3JI=QI(I)/CNCELR*CNO3I(I)
      CNO3JO = 0.0
      IF(QI(I).GE.0.0) GO TO 50
      CNO3JI = 0.0
      CNO3JO = QI(I)/CNCELR
50    CONTINUE
CQ2E + + + + + +
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, NO3S - Section C.
CCC                     C. Initialize diagonal and known terms.
CCC
      REACT = D1LT*KNO2(IOR)*CNO2(IOR)
      REACT = REACT-D1LT*ALPHA1*GROWTH(IOR)*ALGAE(IOR)*(1.0-PRF(IOR))
      B(IOR)=X(IOR)-CNO3JO*DTOVCL(IOR)
      S(IOR)=CNO3(IOR)
      IF (ISS.GT.0) S(IOR)=0.0
      S(IOR)=S(IOR)+REACT+CNO3JI*DTOVCL(IOR)
CCC
CCC                     C.6 For Type 2, 3, 4, and 5 elements
CCC                          the nitrate balance is now complete.
CCC
      IFL=IFLAG(I,J)
      GO TO (101,100,100,100,109,103,104), IFL
CCC
CCC             NCASI Commentary, NO3S - Section D.
CCC                     D. Nitrate balance for Type 1 element.
CCC
  101 NHW=NHW+1
      S(IOR)=S(IOR)-A(IOR)*HWNO3(NHW)
      GO TO 100
CCC
CCC             NCASI Commentary, NO3S - Section E.
CCC                     E. Nitrate balance for Type 6 element.
CCC
  103 NWS=NWS+1
      S(IOR)=S(IOR)+WSFLOW(NWS)*WSNO3 (NWS)*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, NO3S - Section F.
CCC                     F. Nitrate balance for Type 7 element.
CCC
  104 NWS=NWS+1
      B(IOR)=B(IOR)-WSFLOW(NWS)*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 100
      S(IOR) = S(IOR) - C(IOR)*CNO3LB
CCC
CCC             NCASI Commentary, NO3S - Section G.
CCC                     G. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, NO3S - Section H.
CCC                     H. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE REAERC
C
C                             REAERC CAN EITHER READ IN REAERATION
C                             COEFFICIENTS (OPTION1), COMPUTE THEM
C                             USING A SELECTED EQUATION (OPTION 2,3,
C                             4,5, AND 6), OR COMPUTE THEM BASED ON
C                             K2=A*Q**B.  ALL K2'S  ARE TO THE BASE E.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
C
CCC
CCC             NCASI Commentary, REAERC - Section A. (QUAL2 Step 1-0)
CCC                     A. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      KOPT=K2OPT(I)
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      IFL=IFLAG(I,J)
CCC
CCC                     A.7 Calculate K2 for each element,
CCC                          according to KOPT option.
CCC                          (QUAL2 Step 1-1)
C
C                                       KOPT = 1  K2 IS READ IN.
C                                       KOPT = 2  CHURCHILL (1962)
C                                       KOPT = 3  O'CONNER - DOBBINS (19
C                                       KOPT = 4  OWENS, EDWARDS, - GIBB
C                                       KOPT = 5  THACKSTON - KRENKEL (1
C                                       KOPT = 6  LANGBIEN - DURUM (1967
C                                       KOPT = 7  K2 = A * Q ** B
C                                       KOPT = 8  TSIVOGLOU - WALLACE (1
C
      GO TO (101,102,103,104,105,106,107,108), KOPT
CC
CC              The following changes have been made to the
CC               K2 equations.
CC
CC                      1. Incorporate the correct ln(10) = 2.3026
CC                          into the coefficient of the K2
CC                          equations.  This change affects
CC                          options 2, 4, 5, and 6.
CC
CC                      2. Incorporate the numerical value of
CC                          Dm into the coefficient of the
CC                          O'Connor-Dobbins equation.
CC
CC                      3. Change the exponent on depth in the
CC                          Langbein-Durum equation to 1.33 as
CC                          originally given in their paper.
CC
CC                      4. Correct units of K2 from per hour to
CC                          per day for Tsivoglou-Wallace option.
CC
  101 K2(IOR)=CK2(I)
CCC
CCC             NCASI Commentary, REAERC - Section B.
CCC                     B. Option 1: K2 read in (base e, 20 C).
CCC
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section C.
CCC                     C. Option 2: Churchill.
CCC
  102 K2(IOR)=11.57*VEL(IOR)**0.969/DEPTH(IOR)**1.673
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section D.
CCC                     D. Option 3: O'Connor-Dobbins.
CCC
103     K2(IOR) = 12.96*SQRT(VEL(IOR))/DEPTH(IOR)**1.5
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section E.
CCC                     E. Option 4: Owens, Edwards, and Gibbs.
CCC
  104 K2(IOR)=21.64*VEL(IOR)**0.67/DEPTH(IOR)**1.85
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section F.
CCC                     F. Option 5: Thackston-Krenkel.
CCC
  105 F=0.176*VEL(IOR)/SQRT(DEPTH(IOR))
      SHRVEL=5.675*VEL(IOR)*CMANN(I)/(1.49*DEPTH(IOR)**1.167)
      K2(IOR)=24.88*(1.0+SQRT(F))*SHRVEL
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section G.
CCC                     G. Option 6: Langbein-Durum.
CCC
  106 K2(IOR)=7.60*VEL(IOR)/DEPTH(IOR)**1.33
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section H.
CCC                     H. Option 7: Correlation with flow.
CCC
  107 K2(IOR)=COEQK2(I)*FLOW(IOR)**EXPQK2(I)
      GO TO 100
CCC
CCC             NCASI Commentary, REAERC - Section I.
CCC                     I. Option 8: Tsivoglou-Wallace.
CCC
  108 CC2 = COEQK2(I)
      SLOPE1 = EXPQK2(I)
      IF(SLOPE1.GT.0.0) GO TO 81
      IF(CMANN(I).GT.0.0) GO TO 82
      WRITE(NJ,999)
  999 FORMAT(1H1,10X,54H***IMPROPER PARAMETER SPECIFICATION FOR K2 OPTIO
     1N 8 -- /11X,42H***MUST SPECIFY CHANNEL SLOPE OR ROUGHNESS )
C//   CALL EXIT
      STOP
C  CALCULATE DELTA H FROM CHANNEL SLOPE
   81 K2(IOR) = SLOPE1 * VEL(IOR) * CC2 * 3600. * 24.
      GO TO 100
C  CALCULATE DELTA H FROM MANNING EQ.
   82 XK2T = CMANN(I)*CMANN(I)*VEL(IOR)**3/DEPTH(IOR)**(4./3.)
      K2(IOR) = CC2*XK2T*1630.3*24.0
CCC
CCC             NCASI Commentary, REAERC - Section J.
CCC                     J. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, REAERC - Section K.
CCC                     K. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE DOS
CC
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
CDWD - DOS UPDATE from specifications provided by J. Kreider            02/92
CDWD   State of Wisconsin                                               02/92
CDWD   Date: Wednesday, 26 February 1992.  Time: 16:58:12.              02/92
CDWD   Version 3.15                                                     02/92
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

CC
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      REAL*4 TERM1, IANC
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      CHARACTER*4       UBOD
      DATA UBOD /' 5-D'/
CCC
CCC             NCASI Commentary, DOS - Section A.
CCC                     A. Convert 5 day BOD to ultimate (or
CCC                         vice-versa) if title card number 7
CCC                         specifies BOD input data as 5 day.
CCC
C-.....
C.....CONVERT BETWEEN ULTIMATE AND 5-DAY BOD BASED ON AN ASSUMED
C.....LAB DECAY RATE OF 0.23/DAY (BASE E )........WRN......
C.....
      IF(TITLE(7,6).NE.UBOD) GO TO 50
      CFBOD = 1.0 - EXP( -5.0*KBOD)
      IVERT = 0
   10 IVERT = IVERT + 1
      IF( NHWTRS .LE. 0 ) GO TO 25
      DO 20 J = 1, NHWTRS
      HWBOD(J) = HWBOD(J) / CFBOD
   20 CONTINUE
   25 IF( NWASTE .LE. 0 ) GO TO 35
      DO 30 J = 1, NWASTE
      WSBOD(J) = WSBOD(J) / CFBOD
   30 CONTINUE
   35 DO 45 J = 1, NREACH
      BODI(J) = BODI(J) / CFBOD
      NCELR = NCELRH(J)
      DO 40 K = 1, NCELR
      IOR = ICLORD(J,K)
      BOD(IOR) = BOD(IOR) / CFBOD
   40 CONTINUE
   45 CONTINUE
      BODLB = BODLB/CFBOD
CCC
CCC                     B.6 Test IVERT for first of second
CCC                          pass. Return to MAIN.
CCC
      IF( IVERT .GE. 2 ) RETURN
      CFBOD = 1.0 / CFBOD
CCC
CCC             NCASI Commentary, DOS - Section B.
CCC                     B. Initialize counters and constants.
CCC
   50 CONTINUE
      NHW=0
      NWS=0
      IJUNC=0
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      IANC=0.0
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      FACT = 1.0 / (28.3 * 86400.0)
      FACT1 = 1.0/(28.3*86.4)
C3.0
      ATMP = ATMPR/29.9
C3.0
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      IF(TITLE(15,13).EQ.'2BOD') THEN IANC=1.0
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
CCC
CCC             NCASI Commentary, DOS - Section C.
CCC                     C. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 100 I=1,NREACH
      NCELR=NCELRH(I)
      CNCELR=NCELR
CQ2E + + + + + + + +
      DOIJI=QI(I)/CNCELR*DOI(I)
      DOIJO = 0.0
      IF(QI(I).GE.0.0) GO TO 60
      DOIJI = 0.0
      DOIJO = QI(I)/CNCELR
60    CONTINUE
CQ2E + + + + + + + +
C3.0
      IF(ISS.GT.1) ATMP = RCHATM(I)/29.9
C3.0
C     RATIO=1.0/(1.0-EXP(-5.0*CK1(I)))
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
CCC
CCC             NCASI Commentary, DOS - Section D.
CCC                     D. Initialize diagonal and known terms.
CCC
      TC=0.556*(T(IOR)-68.0)
      S(IOR)=DO2(IOR)
      IF (ISS.GT.1) S(IOR)=0.0
      IF (MODOPT(4).LT.1) GO TO 90
      AREACT=(ALPHA3*GROWTH(IOR)-ALPHA4*RESPRR(IOR))*D1LT
      S(IOR) = S(IOR) + AREACT*ALGAE(IOR)
   90 IF (MODOPT(6).LT.1) GO TO 92
      S(IOR) = S(IOR) - (ALPHA5*KNH3(IOR)*CNH3(IOR)+
     1                   ALPHA6*KNO2(IOR)*CNO2(IOR))*D1LT
92      SOD(IOR) = CK4(I)*THETA(4)**TC
        S(IOR) = S(IOR) - SOD(IOR)*BAREA(IOR)*DTOVCL(IOR)*FACT1
C     K1(IOR)=K1(IOR)*RATIO
        TK = 273.15 + (T(IOR)-32.0)*5./9.
        DSM = -139.34410+(1.575701E+05/TK)
     1       -(6.642308E+07/(TK*TK))
     2       +(1.243800E+10/(TK*TK*TK))
     3       -(8.621949E+11/(TK*TK*TK*TK))
      DOSAT(IOR) = EXP(DSM)
C     DOSAT(IOR)=24.89-0.4259*T(IOR)+0.003734*T(IOR)**2-0.00001328
C     1*T(IOR)**3
C3P1
C3P1   CORRECT DOSAT FOR ATMP, IF VALUE IS GIVEN
C3P1
        IF(ATMP.LE.0.1) GO TO 95
        PWV = 11.8571-(3840.70/TK) - 216961./(TK*TK)
        PWV = EXP(PWV)
        THETAW = 0.000975 - (1.426E-05*TC)
     1 + (6.436E-08*TC*TC)
        PNUM = (1.0-PWV/ATMP)*(1.0-THETAW*ATMP)
        PDENOM = (1.0-PWV)*(1.0-THETAW)
        DOSAT(IOR) = DOSAT(IOR)*ATMP*PNUM/PDENOM
95      CONTINUE
CC
CC              Remove the constraint on DO saturation.
CC
CC    IF (DO2(IOR).GT.DOSAT(IOR)) DO2(IOR) = DOSAT(IOR)
CC
      IFL=IFLAG(I,J)
      GO TO (101,102,102,104,109,103,105), IFL
CCC
CCC             NCASI Commentary, DOS - Section E.
CCC                     E. DO balance on Type 1 element.
CCC
  101 NHW=NHW+1
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      TERM1=KANC(IOR)*ANC(IOR)*IANC
      REACT=D1LT*(XK2(IOR)*DOSAT(IOR)-K1(IOR)*BOD(IOR)-TERM1)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      S(IOR)=S(IOR)+REACT+DOIJI*DTOVCL(IOR)-A(IOR)*HWDO(NHW)
      B(IOR)=X(IOR)+D1LT*XK2(IOR)-DOIJO*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, DOS - Section F.
CCC                     F. DO balance on Type 2, 3, and 5 elements.
CCC
102   CONTINUE
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      TERM1=KANC(IOR)*ANC(IOR)*IANC
      REACT=D1LT*(XK2(IOR)*DOSAT(IOR)-K1(IOR)*BOD(IOR)-TERM1)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      S(IOR)=S(IOR)+REACT+DOIJI*DTOVCL(IOR)
      B(IOR)=X(IOR)+D1LT*XK2(IOR)-DOIJO*DTOVCL(IOR)
      IF(JDAM(IOR).EQ.0) GO TO 100
      IDAM = JDAM(IOR)
      AVTEMP = (((T(IOR-1)+T(IOR))*.5) - 32.0)*5./9.
      DENOM = 1.0 + .116*ADAM(IDAM)*BDAM(IDAM)*(1.0+0.046*AVTEMP)*
     1 (1-0.034*HDAM(IDAM))*HDAM(IDAM)
        RHS = (1.0 - 1.0/DENOM)*(DOSAT(IOR-1)-DO2(IOR-1))
        DAMO2(IDAM) = RHS-DOSAT(IOR-1) + DOSAT(IOR)
        S(IOR) = S(IOR) + DAMO2(IDAM)*FDAM(IDAM)*FLOW(IOR-1)*
     1 DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, DOS - Section G.
CCC                     G. DO balance on Type 6 element.
CCC
  103 NWS=NWS+1
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      TERM1=KANC(IOR)*ANC(IOR)*IANC
      REACT=D1LT*(XK2(IOR)*DOSAT(IOR)-K1(IOR)*BOD(IOR)-TERM1)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      S(IOR)=S(IOR)+REACT+(DOIJI+WSFLOW(NWS)*WSDO(NWS))*DTOVCL(IOR)
      B(IOR)=X(IOR)+D1LT*XK2(IOR)-DOIJO*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, DOS - Section H.
CCC                     H. DO balance on Type 4 element.
CCC
  104 IJUNC=IJUNC+1
      NS=1
      NN=JUNC(IJUNC,NS)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      TERM1=KANC(IOR)*ANC(IOR)*IANC
      REACT=D1LT*(XK2(IOR)*DOSAT(IOR)-K1(IOR)*BOD(IOR)-TERM1)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      S(IOR)=S(IOR)+REACT+DOIJI*DTOVCL(IOR)
      B(IOR)=X(IOR)+D1LT*XK2(IOR)-DOIJO*DTOVCL(IOR)
      GO TO 100
CCC
CCC             NCASI Commentary, DOS - Section I.
CCC                     I. DO balance on Type 7 element.
CCC
  105 NWS=NWS+1
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      TERM1=KANC(IOR)*ANC(IOR)*IANC
      REACT=D1LT*(XK2(IOR)*DOSAT(IOR)-K1(IOR)*BOD(IOR)-TERM1)
CDWD ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 02/92
      S(IOR)=S(IOR)+REACT+DOIJI*DTOVCL(IOR)
      B(IOR)=X(IOR)+D1LT*XK2(IOR)-(DOIJO+WSFLOW(NWS))*DTOVCL(IOR)
      GO TO 100
109   IF(LBFLG.EQ.0) GO TO 102
      S(IOR) = S(IOR) - C(IOR)*DOLB
      GO TO 102
CCC
CCC             NCASI Commentary, DOS - Section J.
CCC                     J. Loop through all elements and reaches.
CCC
  100 CONTINUE
CCC
CCC             NCASI Commentary, DOS - Section K.
CCC                     K. Test Title 7 for 5 day BOD data.
CCC
CCC                     L. Return to MAIN.
CCC
      IF(TITLE(7,6).NE.UBOD) RETURN
      GO TO 10
      END
      SUBROUTINE WRPT1
C
C + + + + + + + + + +
C
C      THIS SUBROUTINE PRINTS OUT THE CONDITIONS UNDER
C       WHICH THE STEADY STATE ALGAE SIMULATIONS ARE PERFORMED.
C
C + + + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
CQ2E
CQ2E            WRITE STEADY STATE ALGAE SUMMARY
CQ2E
        WRITE(NJ,8805)
        WRITE(NJ,8807) LAVOPT
        GO TO (8810,8820,8830,8840) LAVOPT
8810    CONTINUE
        WRITE(NJ,8811)
        WRITE(NJ,8812)
        TSNT = BASNET/3.685
        WRITE(NJ,8813) BASNET,TSNT
        WRITE(NJ,8814) BADLH
        WRITE(NJ,8815) TFACT
        WRITE(NJ,8816) AFACT
        GO TO 8850
8820    CONTINUE
        WRITE(NJ,8811)
        WRITE(NJ,8822)
        SNT = SONET/3.685
        WRITE(NJ,8813) SONET,SNT
        WRITE(NJ,8814) BADLH
        WRITE(NJ,8825)
        WRITE(NJ,8816) AFACT
        GO TO 8850
8830    CONTINUE
        WRITE(NJ,8831)
        WRITE(NJ,8812)
        TSNT = BASNET/3.685
        WRITE(NJ,8813) BASNET,TSNT
        WRITE(NJ,8814) BADLH
        WRITE(NJ,8815) TFACT
        WRITE(NJ,8836)
        WRITE(NJ,8837)
        DO 8838 KI = 1,8
        KI1 = KI+8
        KI2 = KI1 +8
        TSN = BATSUN(KI)/3.685
        TSN1 = BATSUN(KI1)/3.685
        TSN2 = BATSUN(KI2)/3.685
8838    WRITE(NJ,8839) KI,TSN,KI1,TSN1,KI2,TSN2
        GO TO 8850
8840    CONTINUE
        WRITE(NJ,8831)
        WRITE(NJ,8842)
        SNT = SONET/3.685
        WRITE(NJ,8813) SONET,SNT
        WRITE(NJ,8814) BADLH
        WRITE(NJ,8825)
        WRITE(NJ,8836)
        WRITE(NJ,8837)
        DO 8848 KI = 1,8
        KI1 = KI+8
        KI2 = KI1+8
        SN = SUN(KI)/3.685
        SN1 = SUN(KI1)/3.685
        SN2 = SUN(KI2)/3.685
8848    WRITE(NJ,8839) KI,SN,KI1,SN1,KI2,SN2
8850    CONTINUE
        WRITE(NJ,8851) LFNOPT
        CKLM = CKL/(60.*3.685)
        GO TO (8855,8860,8865) LFNOPT
8855    WRITE(NJ,8856)CKLM
        GO TO 8870
8860    WRITE(NJ,8861) CKLM
        GO TO 8870
8865    WRITE(NJ,8866) CKLM
8870    CONTINUE
        WRITE(NJ,8871) LGROPT
        GO TO (8875,8880,8885) LGROPT
8875    WRITE(NJ,8876)
        GO TO 8890
8880    WRITE(NJ,8881)
        GO TO 8890
8885    WRITE(NJ,8886)
8890    CONTINUE
C
      JJ=0
      DO 800 I=1,NCELLS
      IF(ALGAE(I).GE.50.) JJ=JJ+1
800   CONTINUE
      IF(JJ.LE.0) GO TO 810
      WRITE(NJ,805) JJ
810   CONTINUE
C
C + + + + + + +    FORMAT STATEMENTS
C
805   FORMAT(///5X,'**WARNING:  COMPUTED ALGAE CONCENTRATION (CHL-A)',
     1' EXCEEDS MAXIMUM'/5X,10('-'),'  PROGRAM CONSTRAINT (2500 UG/L',
     2') IN ',I4,' COMPUTATIONAL ELEMENTS.  CHL-A CONCENTRATION',
     3' IN THESE ELEMENTS'/17X,'IS SET EQUAL TO 2500 UG/L'/)
8805    FORMAT(///2X,'SUMMARY OF CONDITIONS FOR ALGAL GROWTH RATE',
     1' SIMULATION:'/2X,55('-'))
8807    FORMAT(/8X,'1. LIGHT AVERAGING OPTION.   LAVOPT=',I2)
8811    FORMAT(/12X,'METHOD: MEAN SOLAR RADIATION DURING DAY',
     1'LIGHT HOURS')
8812    FORMAT(/12X,'SOURCE OF SOLAR VALUES: SUBROUTINE HEATER',
     1' (SS TEMP)')
8813    FORMAT(16X,'DAILY NET SOLAR RADIATION:',F10.3,' BTU/',
     1'FT-2 (',F9.3,' LANGLEYS)')
8814    FORMAT(16X,'NUMBER OF DAYLIGHT HOURS:',F5.1)
8815    FORMAT(16X,'PHOTOSYNTHETIC ACTIVE FRACTION OF SOLAR',
     1' RADIATION (TFACT):',F6.2)
8816    FORMAT(16X,'MEAN SOLAR RADIATION ADJUSTMENT FACTOR',
     1' (AFACT):',F6.3)
8822    FORMAT(/12X,'SOURCE OF SOLAR VALUES:   DATA TYPE 1A')
8825    FORMAT(16X,'PHOTOSYNTHETIC ACTIVE FRACTION OF SOLAR',
     1' RADIATION (TFACT): N/A')
8831    FORMAT(/12X,'METHOD: AVERAGE OF HOURLY SOLAR VALUES')
8836    FORMAT(16X,'MEAN SOLAR RADIATION ADJUSTMENT FACTOR',
     1' (AFACT): N/A')
8837    FORMAT(/12X,'HOURLY VALUES OF SOLAR RADIATION (LANGLEYS)'/)
8839    FORMAT(10X,3(I5,F9.2,5X))
8842    FORMAT(/12X,'SOURCE OF SOLAR VALUES:  DATA TYPE 1A AND',
     1' COSINE FUNCTION (INTERNAL)')
8851    FORMAT(//8X,'2. LIGHT FUNCTION OPTION:   LFNOPT=',I2)
8856    FORMAT(/12X,'HALF SATURATION METHOD, WITH HALF SATURATION',
     1' COEF =',F7.3,' LANGLEYS/MIN')
8861    FORMAT(/12X,'SMITH FUNCTION, WITH 71% IMAX =',F7.3,
     1' LANGLEYS/MIN')
8866    FORMAT(/12X,'STEELE FUNCTION, WITH IMAX =',F7.3,
     1' LANGLEYS/MIN')
8871    FORMAT(//8X,'3. GROWTH ATTENUATION OPTION FOR NUTRIENTS.',
     1'   LGROPT=',I2)
8876    FORMAT(/12X,'MULTIPLICATIVE:   FL*FN*FP')
8881    FORMAT(/12X,'MINIMUM OF NITROGEN, PHOSPHORUS:   FL*MIN(FN,FP)')
8886    FORMAT(/12X,'HARMONIC MEAN:     2.0*FL/(1/FN+1/FP)')
C
C + + + + + + +
C
      RETURN
      END
      SUBROUTINE WRPTI
C
C + + + + + + + +
C
C      THIS SUBROUTINE CONTROLS INTERMEDIATE OUTPUT FOR A STEADY
C       STATE SIMULATION.
C
C + + + + + + + +
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
CCC
CCC                     I.2 Test model options for printing
CCC                          intermediate output.
CCC
      IF (MODOPT(2)) 1011,1011,1002
 1002 NT=6
      CALL WRPT2(T)
 1011 CONTINUE
      IF (MODOPT(7)) 1021,1021,1012
 1012 NT=13
      CALL WRPT2(DO2)
 1021 CONTINUE
      IF (MODOPT(3)) 1031,1031,1022
 1022 NT=7
      CALL WRPT2(BOD)
 1031 CONTINUE
      IF (MODOPT(6)) 1041,1041,1032
1032    NT=21
        CALL WRPT2(CNH2)
        NT=10
      CALL WRPT2(CNH3)
      NT=11
      CALL WRPT2 (CNO2)
      NT=12
      CALL WRPT2 (CNO3)
 1041 CONTINUE
      IF (MODOPT(5)) 1051,1051,1042
1042    NT=22
        CALL WRPT2(PORG)
        NT=9
      CALL WRPT2 (PHOS)
 1051 CONTINUE
      IF (MODOPT(4)) 1061,1061,1052
 1052 NT=8
      CALL WRPT2 (ALGAE)
 1061 CONTINUE
      IF (MODOPT(8)) 1071,1071,1062
 1062 NT=14
      CALL WRPT2 (COLI)
 1071 CONTINUE
      IF (MODOPT(1)) 1081,1081,1072
 1072 NT=3
      DO 1075 NC=1,NCS
      CALL WRPT2 (CONS(1,NC))
 1075 NT=NT+1
 1081 CONTINUE
      IF (MODOPT(9)) 1091,1091,1082
 1082 NT=15
      CALL WRPT2 (ANC)
 1091 CONTINUE
CCC
CCC                     I.3 Test for algae routing to print GROWth
CCC                          rates and p/r ratios.
CCC
      IF (MODOPT(4).EQ.0) GO TO 9965
C
      NT=19
      CALL WRPT2 (GROWTH)
C
      XTEMP = ALPHA3/ALPHA4
      DO 9960 I=1,NCELLS
      Z(I) = XTEMP*GROWTH(I)/RESPRR(I)
 9960 CONTINUE
      NT = 20
      CALL WRPT2(Z)
 9965 CONTINUE
C
C + + + + + + +
C
      RETURN
      END
       SUBROUTINE FLOAUG
C
C                             FLOAUG SEARCHES THROUGH THE SYSTEM BY
C                             REACH TO DETERMINE THE MINIMUM DO LEVEL
C                             WITHIN EACH REACH. EACH OF THESE MINIMUM
C                             DO LEVELS IS CHECKED AGAINST A SELECTED
C                             TARGET LEVEL. IF FLOW AUGMENTATION IS
C                             REQUIRED, THIS FLOW IS DISTRIBUTED
C                             EQUALLY AMONG THE HEADWATER SOURCES THAT
C                             ARE AVAILABLE TO A GIVEN REACH.
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
C
      DIMENSION IORMIN(MR),RMILE(MR),DOMIN(MR),IORDER(MR),QAUG(MH)
CCC
CCC             NCASI Commentary, FLOAUG - Section A. (QUAL2 Step 1-0)
CCC                     A. Initialize augmentation flows.
CCC
      DO 5 NHW=1,NHWTRS
      QAUG(NHW)=0.0
    5 CONTINUE
CCC
CCC             NCASI Commentary, FLOAUG - Section B. (QUAL2 Step 2-0)
CCC                     B. Loop through reaches to find the
CCC                         the minimun DO in the reach and
CCC                         its location.
CCC
      DO 50 I=1,NREACH
      DOMIN(I)=100.0
      IF(NHWWAR(I).EQ.0) GO TO 50
      NCELR=NCELRH(I)
      DO 100 J=1,NCELR
      IOR=ICLORD(I,J)
      IF (DO2(IOR).GE.DOMIN(I)) GO TO 100
      DOMIN(I)=DO2(IOR)
      IORMIN(I)=IOR
      XMIN=J
      RMILE(I)=RMTHOR(I)-XMIN*DELX/5280.0
  100 CONTINUE
   50 CONTINUE
      NBTARG=0
CCC
CCC             NCASI Commentary, FLOAUG - Section C. (QUAL2 Step 3-0)
CCC                     C. Test whether minimum DO is below the
CCC                         target DO.
CCC
      DO 25 I=1,NREACH
      IF (DOMIN(I).GE.TARGDO(I)) GO TO 25
CCC
CCC             NCASI Commentary, FLOAUG - Section D. (QUAL2 Step 3-1)
CCC                     D. If there is a violation of the target
CCC                         DO, compute the amount of flow
CCC                         augmentation required for the reach.
CCC
      NBTARG=NBTARG+1
      IORDER(NBTARG)=I
      IOR=IORMIN(I)
      RMILE(NBTARG)=RMILE(I)
      DOREQD=TARGDO(I)-DOMIN(I)+0.1
      QREQD = FLOW(IOR)*(DOREQD/TARGDO(I) + 0.15*
     *(DOREQD/TARGDO(I))**2)
CCC
CCC             NCASI Commentary, FLOAUG - Section E.
CCC                     E. Determine the augmentation flow already
CCC                         being supplied to this reach because
CCC                         of upstream reaches with DO
CCC                         violations.
CCC
      QSUM=0.0
      NHWAR=NHWWAR(I)
      DO 350 J=1,NHWAR
      NHW=IAUGOR(I,J)
      QSUM=QSUM+QAUG(NHW)
  350 CONTINUE
CC
CCC
CCC             NCASI Commentary, FLOAUG - Section F. (QUAL2 Step 3-2)
CCC                     F. Divide the augmentation flow for this
CCC                         reach equally among the number of
CCC                         available headwaters.
CCC
      QADD=QREQD/NHWWAR(I)
CCC
CCC             NCASI Commentary, FLOAUG - Section G. (QUAL2 Step 3-3)
CCC                     G. Calculate and/or update the augmentation
CCC                         flow to be supplied from each
CCC                         available headwater source.
CCC
      IF (QREQD.LT.QSUM) GO TO 25
      NHWAR=NHWWAR(I)
      DO 375 J=1,NHWAR
      NHW=IAUGOR(I,J)
      QAUG(NHW)=QADD
  375 CONTINUE
   25 CONTINUE
CCC
CCC             NCASI Commentary, FLOAUG - Section H.
CCC                     H. Test the number of target DO violations
CCC                         for the form of output/exit mode.
CCC
      IF (NBTARG.EQ.0) GO TO 300
CCC
CCC             NCASI Commentary, FLOAUG - Section I. (QUAL2 Step 4-0)
CCC                     I. Intermediate augmentation summary.
CCC
CBR      WRITE (NJ,200)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
C +++++
C      IF(METOUT.EQ.O) WRITE (NJ,200)
C      IF(METOUT.NE.O) WRITE (NJ,201)
      IF(METOUT.EQ.0) WRITE (NJ,200)
      IF(METOUT.NE.0) WRITE (NJ,201)
C +++++
CBR                                        !
CBR                                        !
CBR----------------------------------------!
  200 FORMAT (1H1,38X,39H* * * REACHES WITH OXYGEN DEFICIT * * *,//,23X,
     *        52HREACH NO.     REACH IDENTIFICATION       MINIMUM DO.,
     *        15H     RIVER MILE,/)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
  201 FORMAT (1H1,38X,39H* * * REACHES WITH OXYGEN DEFICIT * * *,//,23X,
     *        52HREACH NO.     REACH IDENTIFICATION       MINIMUM DO.,
     *        15H     RIVER KILO,/)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
CCC
CCC                     I.2 Set routing counter to zero.
CCC
      TIME=0.0
      DO 250 K=1,NBTARG
      I=IORDER(K)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      RX1=RMILE(I)
C +++++
C      IF(METOUT.NE.O) RX1=RX1/1.609
      IF(METOUT.NE.0) RX1=RX1/1.609
C +++++
      WRITE (NJ,255) I,(RCHID(I,J),J=1,5),DOMIN(I),RX1
CBR                                        !
CBR                                        !
CBR----------------------------------------!
CBR      WRITE (NJ,255) I,(RCHID(I,J),J=1,5),DOMIN(I),RMILE(I)
  255 FORMAT (22X,I5,10X,5A4,7X,F5.1,11X,F6.1)
  250 CONTINUE
CBR      WRITE (NJ,260)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      IF(METOUT.EQ.0) WRITE (NJ,260)
      IF(METOUT.NE.0) WRITE (NJ,262)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
  260 FORMAT (1H0,30X,38H* * * FLOW AUGMENTATION REQUIRED * * *,//,
     *        5X,100HHEADWATER NO.     HEADWATER IDENTIFICATION     EXIS
     *TING HEADWATER FLOW (CFS)     AUG. REQUIRED (CFS),/)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
  262 FORMAT (1H0,30X,38H* * * FLOW AUGMENTATION REQUIRED * * *,//,
     *        5X,100HHEADWATER NO.     HEADWATER IDENTIFICATION     EXIS
     *TING HEADWATER FLOW (m3/s)   AUG. REQUIRED (m3/s),/)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
      DO 270 NHW=1,NHWTRS
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      QX1=HWFLOW(NHW)
      QX2=QAUG(NHW)
      IF(METOUT.EQ.0) GO TO 33
      QX1=QX1/35.3233
      QX2=QX2/35.3233
   33 WRITE (NJ,275) NHW,(HWTRID(NHW,J),J=1,5),QX1,QX2
CBR                                        !
CBR                                        !
CBR----------------------------------------!
CBR     WRITE (NJ,275) NHW,(HWTRID(NHW,J),J=1,5),HWFLOW(NHW),QAUG(NHW)
  275 FORMAT (8X,I5,12X,5A4,16X,F10.1,20X,F10.1)
  270 CONTINUE
      DO 380 NHW=1,NHWTRS
      HWFLOW(NHW) = HWFLOW(NHW) + QAUG(NHW)
  380 CONTINUE
      GO TO 310
  300 CONTINUE
CCC
CCC             NCASI Commentary, FLOAUG - Section J. (QUAL2 Step 5-0)
CCC                     J. Final augmentation summary.
CCC
CBR      WRITE (NJ,261)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      IF(METOUT.EQ.0) WRITE (NJ,261)
      IF(METOUT.NE.0) WRITE (NJ,263)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
  261 FORMAT (1H0,33X,32HTOTAL FLOW AUGMENTATION REQUIRED,//,
     *5X,101HHEADWATER NO.     HEADWATER IDENTIFICATION      INITIAL  HE
     *ADWATER FLOW (CFS)     AUG. REQUIRED (CFS),/)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
  263 FORMAT (1H0,33X,32HTOTAL FLOW AUGMENTATION REQUIRED,//,
     *5X,101HHEADWATER NO.     HEADWATER IDENTIFICATION      INITIAL  HE
     *ADWATER FLOW (m3/s)   AUG. REQUIRED (m3/s),/)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
      DO 305 NHW=1,NHWTRS
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      QX1=HWFLOW(NHW)
      QX2=QATOT(NHW)
      IF(METOUT.EQ.0) GO TO 34
      QX1=QX1/35.3233
      QX2=QX2/35.3233
34    HWFLOI=QATOT(NHW)
CBR                                        !
CBR                                        !
CBR----------------------------------------!
      QATOT(NHW)=HWFLOW(NHW)-HWFLOI
      HWFLOW(NHW)=HWFLOI
CBR      WRITE (NJ,275) NHW,(HWTRID(NHW,J),J=1,5),HWFLOW(NHW),QATOT(NHW)
CBR----------------------------------------!
CBR                                        !
CBR                                        !
      WRITE (NJ,275) NHW,(HWTRID(NHW,J),J=1,5),QX1,QX2
CBR                                        !
CBR                                        !
CBR----------------------------------------!
  305 CONTINUE
  310 CONTINUE
CCC
CCC             NCASI Commentary, FLOAUG - Section K.
CCC                     K. Return to MAIN.
CCC
      RETURN
      END
      SUBROUTINE WRPT3A (NPAGE)
C
C                             WRPT3 WRITES THE FINAL CONCENTRATION
C                             OF THE SELECTED QUALITY CONSTITUENTS.
C                             THESE CONSTITUENTS ARE WRITTEN BY REACH
C                             AND BY ELEMENT.
C  UPDATED 6/84 T.WILSON: CORRECTED FORMAT STATEMENTS WHICH
C                         CONTINUED QUOTED STRINGS ACROSS LINES.
C
C
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C
C       FILE: 'JUNCTS.VAR'           JUNCTS COMMON BLOCK FOR QUAL2E
C
        COMMON /JUNCTS/ D(MJ),JUNC(MJ,3)
C
        SAVE /JUNCTS/

C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
C//   DATA NPAGE/0/
      NPAGE = 0
CCC
CCC             NCASI Commentary, WRPT3 - Section A.
CCC                     A. Initialize counters and constants.
CCC
      NHW = 0
      NWS = 0
      LP=LPPG
      DELM = DELX / 5280.0
      IF( METOUT .GT. 0 ) DELM = DELM * 1.609
CCC
CCC             NCASI Commentary, WRPT3 - Section B.
CCC                     B. Set up loop on the number of reaches
CCC                         and elements in the system.
CCC
      DO 300 I = 1, NREACH
      WRITE(NJ,6000)
      LP = LP + 2
      RLTHOR = RMTHOR(I)
      IF( METOUT .GT. 0 ) RLTHOR=RLTHOR*1.609
      NCELR = NCELRH(I)
      CNCELR = NCELR
      QINC = QI(I) / CNCELR
      IF( METOUT .GT. 0 ) QINC = QINC / 35.3133
      DO 300 J = 1, NCELR
      LP = LP + 1
      IF(LP.LT.LPPG)GO TO 288
      LP=0
      NPAGE = NPAGE + 1
CCC
CCC                     B.5 Print page heading.
CCC
      WRITE(NJ,6005) NPAGE,VERNUM
      IF( ISS .EQ. 0 ) WRITE(NJ,6007) TIME
      IF( ISS .GT. 0 ) WRITE(NJ,6008)
CCC
CCC                     B.6 Write units at column headings
CCC                          according to metric/English output.
CCC
      WRITE(NJ,6009)
      IF(METOUT.EQ.0) WRITE(NJ,6010)
      IF(METOUT.GT.0) WRITE(NJ,6011)
  288 IOR = ICLORD(I,J)
CCC
CCC             NCASI Commentary, WRPT3 - Section C.
CCC                     C. Set up to flag headwater flows and
CCC                         point source/withdrawal flows for
CCC                         printing.
CCC
      QHWD = 0.0
      QWSI = 0.0
      IFL = IFLAG(I,J)
      GO TO (290,296,296,296,296,292,294), IFL
  290 NHW = NHW + 1
      QHWD = HWFLOW(NHW)
      GO TO 296
  292 NWS = NWS + 1
      QWSI = WSFLOW(NWS)
      GO TO 296
  294 NWS = NWS + 1
      QWSI = + WSFLOW(NWS)
CCC
CCC             NCASI Commentary, WRPT3 - Section D.
CCC                     D. Define new variables for printing.
CCC
  296 XMH = RLTHOR - FLOAT( J - 1 ) * DELM
      XME = XMH - DELM
      QXX = FLOW(IOR)
      VXX = VEL(IOR)
      DXX = DEPTH(IOR)
      WXX = EWIDTH(IOR)
      VOXX = VOLSEG(IOR)
      BAXX = BAREA(IOR)
      XAXX = XAREA(IOR)
      DLXX = DL(IOR)
      IF( METOUT .EQ. 0 ) GO TO 297
      QWSI = QWSI / 35.3133
      QXX = QXX / 35.3133
      VXX = VXX/3.2808
      DXX = DXX/3.2808
      WXX = WXX/3.2808
      VOXX = VOXX/35.3133
      BAXX = BAXX/10.7636
      XAXX = XAXX/10.7636
      DLXX = DLXX/10.7636
  297 CONTINUE
      VOK = VOXX/1000.
      BAK = BAXX/1000.
CCC
CCC             NCASI Commentary, WRPT3 - Section E.
CCC                     E. Write out primary information,
CCC                         one line per element.
CCC
      WRITE(NJ,6015)IOR,I,J,XMH,XME,QXX,QWSI,QINC,
     1VXX,TRVTM(IOR),DXX,WXX,VOK,BAK,XAXX,DLXX
C3P1   OUTPUT INTERFACE - HYDRAULICS   (LCB-6/89)
      OSIM(IOR,1) = IOR
      OSIM(IOR,2) = I
      OSIM(IOR,3) = J
      OSIM(IOR,5) = XMH
      OSIM(IOR,6) = XME
      OSIM(IOR,7) = QXX
      OSIM(IOR,8) = QWSI
      OSIM(IOR,9) = QINC
      OSIM(IOR,10) = VXX
      OSIM(IOR,11) = TRVTM(IOR)
      OSIM(IOR,12) = DXX
      OSIM(IOR,13) = WXX
      OSIM(IOR,14) = VOK
      OSIM(IOR,15) = BAK
      OSIM(IOR,16) = XAXX
      OSIM(IOR,17) = DLXX
C3P1
  300 CONTINUE
CQET
CQET            WRITE OPTIONAL REACH VARIABLE TEMPERATURE OUTPUT
CQET
      IF(IFGRVT.EQ.0) GO TO 701
      IF(ISS.EQ.0.AND.PTIME.LT.0.0) RETURN
      RHOCP = 62.4
      LP=LPPG
      DELM = DELX/5280.
      IF(METOUT.GT.0) DELM = DELM*1.609
      DO 700 I=1,NREACH
      WRITE(NJ,6000)
      LP = LP + 2
      RLTHOR = RMTHOR(I)
      IF(METOUT.GT.0) RLTHOR = RLTHOR*1.609
      NCELR = NCELRH(I)
      CNCELR = NCELR
      VPWB = 0.1001*EXP(0.03*RCHTWB(I))-0.0837
      VPAIR = VPWB
     *      -0.000367*RCHATM(I)*(RCHTDB(I)-RCHTWB(I))*
     *      (1.0+(RCHTWB(I)-32.)/1571.0)
      CLC = 1.0 + 0.17*RCHCLD(I)**2
      HA = 4.85E-15*(RCHTDB(I)+460.0)**6*CLC
      ELVX = RCHELV(I)
      DBTX = RCHTDB(I)
      WBTX = RCHTWB(I)
      ATMX = RCHATM(I)
      WNDX = RCHWND(I)/0.6818
      HSX = TSONET(I)
      HAX = HA
      IF(METOUT.EQ.0) GO TO 787
      ELVX = ELVX/3.2808
      DBTX = (DBTX-32.0)*(5./9.)
      WBTX = (WBTX-32.0)*(5./9.)
      ATMX = ATMX*1000.0/29.9
      WNDX = WNDX*.3048
      HSX = HSX/3.685
      HAX = HAX/3.685
787   CONTINUE
      DO 700 J=1,NCELR
      LP = LP + 1
      IF(LP.LT.LPPG) GO TO 788
      LP = 0
      NPAGE = NPAGE + 1
      WRITE(NJ,6005) NPAGE,VERNUM
      IF(ISS.EQ.0) WRITE(NJ,6007) TIME
      IF(ISS.GT.0) WRITE(NJ,6008)
      WRITE(NJ,6079)
      IF(METOUT.EQ.0) WRITE(NJ,7080)
      IF(METOUT.GT.0) WRITE(NJ,7081)
      WRITE(NJ,7082)
      IF(METOUT.EQ.0) WRITE(NJ,6080)
      IF(METOUT.GT.0) WRITE(NJ,6081)
788   IOR = ICLORD(I,J)
      TJ = (T(IOR)-35.)/5.
      M=TJ+1
      HLAT = 1084. - 0.5*T(IOR)
      B1=RHOCP*HLAT*(AE+BE*RCHWND(I))
      HB = ALFA2(M)+BETA2(M)*T(IOR)
      HC = B1*0.01*(T(IOR)-RCHTDB(I))
      HE = B1*(ALFA1(M)-VPAIR+BETA1(M)*T(IOR))
      XMH = RLTHOR-FLOAT(J-1)*DELM
      XME = XMH - DELM
      HBX = -HB
      HCX = -HC
      HEX = -HE
      IF(METOUT.EQ.0) GO TO 789
      HBX = HBX/3.685
      HCX = HCX/3.685
      HEX = HEX/3.685
789   CONTINUE
      HNX = HSX+HAX+HBX+HCX+HEX
CQET
CQET       WRITE LCD/HEAT BUDGET DATA
CQET
      IF(METOUT.EQ.0) GO TO 790
      WRITE(NJ,6086) IOR,I,J,XMH,XME,ELVX,RCHDAC(I),
     * RCHCLD(I),DBTX,WBTX,ATMX,WNDX,HSX,HAX,HBX,HCX,
     * HEX,HNX
      GO TO 700
790   WRITE(NJ,6085) IOR,I,J,XMH,XME,ELVX,RCHDAC(I),
     * RCHCLD(I),DBTX,WBTX,ATMX,WNDX,HSX,HAX,HBX,HCX,
     * HEX,HNX
C3P1   OUTPUT INTERFACE - HEAT BUDGET  (LCB-6/89)
      OSIM(IOR,73) = ELVX
      OSIM(IOR,74) = RCHDAC(I)
      OSIM(IOR,75) = RCHCLD(I)
      OSIM(IOR,76) = DBTX
      OSIM(IOR,77) = WBTX
      OSIM(IOR,78) = ATMX
      OSIM(IOR,79) = WNDX
      OSIM(IOR,80) = HSX
      OSIM(IOR,81) = HAX
      OSIM(IOR,82) = HBX
      OSIM(IOR,83) = HCX
      OSIM(IOR,84) = HEX
      OSIM(IOR,85) = HNX
C3P1
700   CONTINUE
701   CONTINUE
CQ2E
CQ2E            WRITE RATE COEFFICIENTS.
CQ2E
      IF( ISS .EQ. 0 .AND. PTIME .LT. 0.0 ) RETURN
      LP=LPPG
      IJUNC = 0
      DO 400 I = 1, NREACH
      WRITE(NJ,6000)
      LP = LP + 2
      NCELR = NCELRH(I)
      DO 400 J = 1, NCELR
      LP = LP + 1
      IF(LP.LT.LPPG)GO TO 350
      LP=0
      NPAGE = NPAGE + 1
      WRITE(NJ,6005) NPAGE,VERNUM
      IF( ISS .EQ. 0 ) WRITE(NJ,6007) TIME
      IF( ISS .NE. 0 ) WRITE(NJ,6008)
      WRITE(NJ,6019)
      IF( METOUT .EQ. 0 ) WRITE(NJ,6020)
      IF( METOUT .GT. 0 ) WRITE(NJ,6021)
  350 IOR = ICLORD(I,J)
CCC
CCC             NCASI Commentary, WRPT3 - Section G.
CCC                     G. Define new variables for printing.
CCC
C 370 XMH = RMTHOR(I) - FLOAT(J-1)*DELM
C     XME = XMH - DELM
      XKC4 = SOD(IOR)
      XSRCN = SRCNH3(IOR)
      XSRCP = SCPHOS(IOR)
      XSRCA = SRANC(IOR)
      IF( METOUT .EQ. 0 ) GO TO 375
      XKC4 = XKC4*10.7636
      XSRCN = XSRCN*10.7636
      XSRCP = XSRCP*10.7636
      XSRCA = XSRCA*10.7636
  375 CONTINUE
CQ2E
CQ2E            WRITE WATER QUALITY VARIABLES
CQ2E
      WRITE(NJ,6025)I,J,DOSAT(IOR),K2OPT(I),XK2(IOR),K1(IOR),
     1  K3(IOR),XKC4,KNH2(IOR),SETNH2(IOR),KNH3(IOR),XSRCN,
     2   KNO2(IOR),KPORG(IOR),STPORG(IOR),XSRCP,K5(IOR),
     3   KANC(IOR),STANC(IOR),XSRCA
C3P1  OUTPUT INTERFACE - RATE COEFFICIENTS  (LCB-6/89)
      OSIM(IOR,18) = DOSAT(IOR)
      OSIM(IOR,19) = K2OPT(I)
      OSIM(IOR,20) = XK2(IOR)
      OSIM(IOR,21) = K1(IOR)
      OSIM(IOR,22) = K3(IOR)
      OSIM(IOR,23) = XKC4
      OSIM(IOR,24) = KNH2(IOR)
      OSIM(IOR,25) = SETNH2(IOR)
      OSIM(IOR,26) = KNH3(IOR)
      OSIM(IOR,27) = XSRCN
      OSIM(IOR,28) = KNO2(IOR)
      OSIM(IOR,29) = KPORG(IOR)
      OSIM(IOR,30) = STPORG(IOR)
      OSIM(IOR,31) = XSRCP
      OSIM(IOR,32) = K5(IOR)
      OSIM(IOR,33) = KANC(IOR)
      OSIM(IOR,34) = STANC(IOR)
      OSIM(IOR,35) = XSRCA
C3P1
  400 CONTINUE
CQ2E
CQ2E            FORMAT STATEMENTS
CQ2E
6000    FORMAT(/)
 6005 FORMAT( 1H1 /
     * 10X, 25HSTREAM QUALITY SIMULATION, 70X, 19HOUTPUT PAGE NUMBER ,I5
     *   /  10X, 36HQUAL-2E STREAM QUALITY ROUTING MODEL, 51X, A26)
C     *  'EPA/NCASI VERSION')
 6007 FORMAT( / 10X, 'SYSTEM STATUS AFTER', F8.2, ' HOURS OF DYNAMIC',
     1'OPERATION'  )
 6008 FORMAT( 50X, 35H***** STEADY STATE SIMULATION *****  )
6009    FORMAT( / 55X,'** HYDRAULICS SUMMARY **'//
     1 ' ELE RCH ELE   BEGIN',5X,'END',11X,'POINT',4X,
     1 'INCR',12X,'TRVL',35X,' BOTTOM',6X,'X-SECT   DSPRSN'/,
     2 ' ORD NUM NUM',2(5X,'LOC'),4X,'FLOW',4X,'SRCE',4X,'FLOW',5X,
     3 'VEL',4X,'TIME',4X,'DEPTH',4X,'WIDTH',6X,'VOLUME',
     4 2(8X,'AREA'),5X,'COEF')
6011    FORMAT(12X,2(4X,'KILO'),3(5X,'CMS'),5X,'MPS',5X,'DAY',
     1  2(8X,'M'),6X,'K-CU-M',6X,
     2  'K-SQ-M',8X,'SQ-M',3X,'SQ-M/S'/)
6010    FORMAT(12X,2(4X,'MILE'),3(5X,'CFS'),5X,'FPS',5X,'DAY',
     2  2(7X,'FT'),6X,'K-FT-3',6X,
     2  'K-FT-2',8X,'FT-2',3X,'FT-2/S'/)
6015    FORMAT(3I4,5F8.2,2F8.3,2F9.3,3F12.2,F9.2)
6019    FORMAT( / 50X,'** REACTION COEFFICIENT SUMMARY **'//
     1' RCH ELE',5X,'DO  K2  OXYGN',2(4X,'BOD'),
     1 4X,'SOD',2(3X,'ORGN'),2(4X,'NH3'),4X,'NO2',
     2 2(3X,'ORGP'),3X,'DISP',3X,'COLI',3(4X,'ANC')/
     3 2(' NUM'),4X,'SAT OPT  REAIR  DECAY   SETT',
     4 '   RATE  DECAY   SETT  DECAY   SRCE',2(2X,'DECAY'),3X,
     5  'SETT   SRCE',2(2X,'DECAY'),3X,'SETT   SRCE')
6020    FORMAT(11X,'MG/L',4X,3(2X,'1/DAY'),2X,'G/F2D',2X,'1/DAY',
     1 '  1/DAY  1/DAY MG/F2D',2(2X,'1/DAY'),2X,'1/DAY MG/F2D',
     2  2(2X,'1/DAY'),2X,'1/DAY MG/F2D'/)
6021    FORMAT(11X,'MG/L',4X,3(2X,'1/DAY'),2X,'G/M2D',2X,'1/DAY',
     1 '  1/DAY  1/DAY MG/M2D',2(2X,'1/DAY'),2X,'1/DAY MG/M2D',
     2  2(2X,'1/DAY'),2X,'1/DAY MG/M2D'/)
6025    FORMAT(2I4,F7.2,I4,16F7.2)
6079  FORMAT(/48X,'**CLIMATOLOGY - HEAT BALANCE SUMMARY**'/)
7080  FORMAT(89X,'COMPONENTS OF SS HEAT BALANCE (BTU/FT-2)')
7081  FORMAT(89X,'COMPONENTS OF SS HEAT BALANCE (LANGLEYS)')
7082  FORMAT(' ELE RCH ELE   BEGIN',5X,'END   ELEV   DUST',
     * '  CLOUD  D BLB  W BLB    ATM   WIND  OTHER',4X,
     * 'SOLAR L WAVE W SURF   COND   EVAP',6X,'NET'/
     * ' ORD NUM NUM',2(5X,'LOC'),21X,2(3X,'TEMP'),3X,'PRSR',
     * 26X,'ATM  BACK R',19X,'HEAT')
6080  FORMAT(12X,2(4X,'MILE'),5X,'FT',14X,2('  DEG-F'),'  IN-HG',
     * '   FT/S',13X,'HS',5X,'HA',5X,'HB',5X,'HC',5X,'HE',7X,
     * 'HN'//)
6081  FORMAT(12X,2(6X,'KM'),6X,'M',14X,2('  DEG-C'),'  M-BAR',
     * '    M/S',13X,'HS',5X,'HA',5X,'HB',5X,'HC',5X,'HE',7X,
     * 'HN'//)
6085  FORMAT(3I4,2F8.2,F7.1,6F7.2,9X,5F7.1,F9.1)
6086  FORMAT(3I4,2F8.2,F7.1,4F7.2,F7.1,F7.2,9X,5F7.1,F9.1)
        END
      SUBROUTINE WRPT3B (NPAGE)
C
C                             WRPT3 WRITES THE FINAL CONCENTRATION
C                             OF THE SELECTED QUALITY CONSTITUENTS.
C                             THESE CONSTITUENTS ARE WRITTEN BY REACH
C                             AND BY ELEMENT.
C  UPDATED 6/84 T.WILSON: CORRECTED FORMAT STATEMENTS WHICH
C                         CONTINUED QUOTED STRINGS ACROSS LINES.
C
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C
C       FILE: 'CHARCT.VAR'           CHARCT COMMON BLOCK FOR QUAL2E
C
C       CHARACTER*4     JUNCID(MJ,5),WASTID(MW,5)
        CHARACTER*4     HWTRID,RCHID,TITLE
C +++++
        CHARACTER*1     DISPYN, RETURN
        CHARACTER*64    MFPATH, UCPATH, FILNAM(10)
        CHARACTER*26    VERNUM
C +++++
C
        COMMON /CHARCT/ HWTRID(MH,5),RCHID(MR,5),TITLE(22,20),DISPYN,
     *                  RETURN
C    *                  JUNCID,WASTID
C
C +++++
        COMMON /PATFIL/ MFPATH, UCPATH, FILNAM
        COMMON /VERSON/ VERNUM
C +++++
C
        SAVE /CHARCT/,/PATFIL/,/VERSON/

C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C
C       FILE: 'HDWTRS.VAR'           HDWTRS COMMON BLOCK FOR QUAL2E
C
C        MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /HDWTRU/ HWFLOW(MH),HWTEMP(MH),HWDO(MH),HWBOD(MH),
     *                  HWCONS(MH,3),HWANC(MH),HWCOLI(MH),HWALG(MH),
     *                  HWNH2(MH),HWNH3(MH),HWNO2(MH),HWNO3(MH),
     *                  HWPORG(MH),HWPHOS(MH)
        COMMON /HDWTRS/ DEPHW(MH),DLHW(MH),
     *                  QATOT(MH),VHW(MH)
C
        SAVE /HDWTRU/,/HDWTRS/

C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C
C       FILE: 'WASTLD.VAR'           WASTLD COMMON BLOCK FOR QUAL2E
C
C           MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /WASTLU/ TRFACT(MW),WSFLOW(MW),WSTEMP(MW),WSDO(MW),
     *                  WSBOD(MW),WSCONS(MW,3),WSANC(MW),WSCOLI(MW),
     *                  WSALG(MW),WSNH2(MW),WSNH3(MW),WSNO2(MW),
     *                  WSNO3(MW),WSPORG(MW),WSPHOS(MW)
C
         SAVE /WASTLU/

C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
        DIMENSION DOMB(7)
CCC
CCC
CCC             NCASI Commentary, WRPT3 - Section I.
CCC                     I. Return to MAIN.
CCC
CCC
CCC
        IF(ISS.EQ.0.AND.PTIME.LT.0.000) RETURN
        LP=LPPG
        DO 500 I=1,NREACH
        NCELR = NCELRH(I)
        WRITE(NJ,6000)
        LP = LP + 2
        DO 500 J=1,NCELR
        LP = LP + 1
        IF(LP.LT.LPPG) GO TO 450
      LP=0
        NPAGE = NPAGE + 1
        WRITE(NJ,6005) NPAGE,VERNUM
        IF(ISS.EQ.0) WRITE(NJ,6007) TIME
        IF(ISS.NE.0) WRITE(NJ,6008)
        WRITE(NJ,6029) (TITLE(II,13),II=3,5),TITLE(15,13)
        IF(METOUT.EQ.0) WRITE(NJ,6030)(TITLE(II,15),II=3,5)
     1 ,TITLE(15,15)
        IF(METOUT.GT.0) WRITE(NJ,6031) (TITLE(II,15),II=3,5)
     1 ,TITLE(15,15)
450     IOR = ICLORD(I,J)
        CALGAE = ALGAE(IOR)*ALPHAO(I)
        TXXX = T(IOR)
        IF(METOUT.GT.0) TXXX = (TXXX-32.0)/1.8
        TOTN = CNH2(IOR) + CNH3(IOR) + CNO2(IOR) + CNO3(IOR)
        TOTP = PORG(IOR) + PHOS(IOR)
        WRITE(NJ,6035) I,J,TXXX,(CONS(IOR,K),K=1,3),DO2(IOR),
     1 BOD(IOR),CNH2(IOR),CNH3(IOR),CNO2(IOR),CNO3(IOR),TOTN,
     2 PORG(IOR),PHOS(IOR),TOTP,COLI(IOR),ANC(IOR),CALGAE
C3P1    OUTPUT INTERFACE - WATER QUALITY VARIABLES  (LCB 6/89)
      OSIM(IOR,36) = TXXX
      DO 501 IO=37,39
      K=IO-36
501   OSIM(IOR,IO) = CONS(IOR,K)
      OSIM(IOR,40) = DO2(IOR)
      OSIM(IOR,41) = BOD(IOR)
      OSIM(IOR,42) = CNH2(IOR)
      OSIM(IOR,43) = CNH3(IOR)
      OSIM(IOR,44) = CNO2(IOR)
      OSIM(IOR,45) = CNO3(IOR)
      OSIM(IOR,46) = TOTN
      OSIM(IOR,47) = PORG(IOR)
      OSIM(IOR,48) = PHOS(IOR)
      OSIM(IOR,49) = TOTP
      OSIM(IOR,50) = COLI(IOR)
      OSIM(IOR,51) = ANC(IOR)
      OSIM(IOR,52) = CALGAE
C3P1
500     CONTINUE
CQ2E + + + + + + +
      IF(LBFLG.EQ.0) GO TO 499
      WRITE(NJ,6036)
6036  FORMAT(/3X,'END OF SYSTEM BOUNDARY CONCENTRATIONS'/)
      XTMPLB = TEMPLB
      IF(METOUT.GT.0) XTMPLB = (XTMPLB-32.0)*5./9.
      SUMNLB = CNH2LB+CNH3LB+CNO2LB+CNO3LB
      SUMPLB = PORGLB + PHOSLB
      CALGLB=ALGLB
C3.0  IF(MODOPT(4).GT.0) CALGLB = ALGLB*ALPHAO(NREACH)
      WRITE(NJ,6037) XTMPLB,(CONSLB(J),J=1,3),DOLB,BODLB,
     1CNH2LB,CNH3LB,CNO2LB,CNO3LB,SUMNLB,PORGLB,PHOSLB,
     1SUMPLB,
     2COLILB,ANCLB,CALGLB
6037  FORMAT(12X,14F7.2,E7.2,2F7.2)
C6037  FORMAT(12X,17F7.2)
499   CONTINUE
CQ2E + + + + + + + +
CQ2E
CQ2E            WRITE ALGAE OUTPUT
CQ2E
        IF(MODOPT(4).EQ.0) GO TO 601
        IF(ISS.EQ.0.AND.PTIME.LT.0.0) RETURN
        LP=LPPG
        COEF = ALPHA3/ALPHA4
        DO 600 I=1,NREACH
        NCELR = NCELRH(I)
        WRITE(NJ,6000)
        LP = LP + 2
        DO 600 J=1,NCELR
        LP = LP + 1
        IF(LP.LT.LPPG) GO TO 550
      LP=0
        NPAGE = NPAGE + 1
        WRITE(NJ,6005) NPAGE,VERNUM
        IF(ISS.EQ.0) WRITE(NJ,6007) TIME
        IF(ISS.NE.0) WRITE(NJ,6008)
        WRITE(NJ,6039)
        IF(METOUT.EQ.0) WRITE(NJ,6040)
        IF(METOUT.GT.0) WRITE(NJ,6041)
550     IOR = ICLORD(I,J)
        CALGAE = ALGAE(IOR)*ALPHAO(I)
        PRRAT = COEF*GROWTH(IOR)/RESPRR(IOR)
        PRNET = (ALPHA3*GROWTH(IOR)-ALPHA4*RESPRR(IOR))*ALGAE(IOR)
        ALGST = AGYSET(IOR)
        IF(METOUT.GT.0)  ALGST = ALGST/3.2808
        EXTCX = EXTC(IOR)
        IF(METOUT.GT.0) EXTCX = EXTCX*3.2808
        WRITE(NJ,6045) IOR,I,J,CALGAE,GROWTH(IOR),RESPRR(IOR),
     1 ALGST,PRRAT,PRNET,PREFN,PRF(IOR),EXTCX,AGFL(IOR),
     2 AGFN(IOR),AGFP(IOR)
C3P1     OUTPUT INTERFACE - ALGAE  (LCB  6/89)
      OSIM(IOR,53) = GROWTH(IOR)
      OSIM(IOR,54) = RESPRR(IOR)
      OSIM(IOR,55) = ALGST
      OSIM(IOR,56) = PRRAT
      OSIM(IOR,57) = PRNET
      OSIM(IOR,58) = PRF(IOR)
      OSIM(IOR,59) = EXTCX
      OSIM(IOR,60) = AGFL(IOR)
      OSIM(IOR,61) = AGFN(IOR)
      OSIM(IOR,62) = AGFP(IOR)
C3P1
600     CONTINUE
CQ2E
CQ2E            WRITE DO OUTPUT
CQ2E
601     CONTINUE
        IF(ISS.EQ.0.AND.PTIME.LT.0.0) RETURN
        LP=LPPG
        NHW = 0
        NWS = 0
        DO 700 I=1,NREACH
        NCELR = NCELRH(I)
        CNCELR = NCELR
        DOIJ = QI(I)/CNCELR*DOI(I)
        WRITE(NJ,6000)
        LP = LP + 2
        DO 700 J=1,NCELR
        LP = LP + 1
        IF(LP.LT.LPPG) GO TO 650
      LP=0
        NPAGE = NPAGE + 1
        WRITE(NJ,6005) NPAGE,VERNUM
        IF(ISS.EQ.0) WRITE(NJ,6007) TIME
        IF(ISS.NE.0) WRITE(NJ,6008)
        WRITE(NJ,6049)
        IF(METOUT.EQ.0) WRITE(NJ,6050)
        IF(METOUT.GT.0) WRITE(NJ,6051)
650     IOR = ICLORD(I,J)
        TXXX = T(IOR)
        IF(METOUT.GT.0) TXXX = (TXXX-32.0)/1.8
        DODEF = DOSAT(IOR)-DO2(IOR)
        DAMIN = 0.0
        IDAM = JDAM(IOR)
        IF(IDAM.NE.0) DAMIN = DAMO2(IDAM)
        IFL = IFLAG(I,J)
        DOMB(1) = DOIJ*86400./VOLSEG(IOR)
        IF(QI(I).LT.0.0)
     *            DOMB(1)=(QI(I)/CNCELR)*DO2(IOR)*86400./VOLSEG(IOR)
        DOMB(2) = XK2(IOR)*DODEF
        DOMB(3) = -K1(IOR)*BOD(IOR)
        DOMB(4) = -(1000./28.317)*SOD(IOR)/DEPTH(IOR)
        DOMB(5) = (ALPHA3*GROWTH(IOR)-ALPHA4*RESPRR(IOR))*ALGAE(IOR)
        DOMB(6) = -ALPHA5*KNH3(IOR)*CNH3(IOR)
        DOMB(7) = -ALPHA6*KNO2(IOR)*CNO2(IOR)
        GO TO (660,670,670,670,670,662,664) IFL
660     NHW = NHW + 1
        DOMB(1) = DOMB(1)+HWFLOW(NHW)*HWDO(NHW)*86400./VOLSEG(IOR)
        GO TO 670
662     NWS = NWS + 1
        DOMB(1) = DOMB(1)+WSFLOW(NWS)*WSDO(NWS)*86400./VOLSEG(IOR)
        GO TO 670
664     NWS = NWS + 1
        DOMB(1) = DOMB(1) + WSFLOW(NWS)*DO2(IOR)*86400./VOLSEG(IOR)
670     CONTINUE
        WRITE(NJ,6055) IOR,I,J,TXXX,DOSAT(IOR),DO2(IOR),DODEF,DAMIN,
     *                 CORDO(IOR),(DOMB(K),K=1,7)
C3P1    OUTPUT INTERFACE - DO MASS BALANCE  (LCB 6/89)
      OSIM(IOR,63) = DODEF
      OSIM(IOR,64) = DAMIN
      OSIM(IOR,65) = CORDO(IOR)
      DO 680 IO=66,72
      K=IO-65
680   OSIM(IOR,IO) = DOMB(K)
C3P1
700     CONTINUE
        RETURN
CQ2E
CQ2E            FORMAT STATEMENTS
CQ2E
6000    FORMAT(/)
 6005 FORMAT( 1H1 /
     * 10X, 25HSTREAM QUALITY SIMULATION, 70X, 19HOUTPUT PAGE NUMBER ,I5
     *   /  10X, 36HQUAL-2E STREAM QUALITY ROUTING MODEL, 51X, A26)
C     *  'EPA/NCASI VERSION')
 6007 FORMAT( / 10X, 'SYSTEM STATUS AFTER', F8.2, ' HOURS OF DYNAMIC',
     1'OPERATION'  )
 6008 FORMAT( 50X, 35H***** STEADY STATE SIMULATION *****  )
C +++++
C6009    FORMAT( / 55X,'** HYDRAULICS SUMMARY **'//
C     1 ' ELE RCH ELE   BEGIN',5X,'END',11X,'POINT',4X,
C     1 'INCR',12X,'TRVL',35X,' BOTTOM',6X,'X-SECT   DSPRSN'/,
C     2 ' ORD NUM NUM',2(5X,'LOC'),4X,'FLOW',4X,'SRCE',4X,'FLOW',5X,
C     3 'VEL',4X,'TIME',4X,'DEPTH',4X,'WIDTH',6X,'VOLUME',
C     4 2(8X,'AREA'),5X,'COEF')
C +++++
6029    FORMAT( / 53X,'** WATER QUALITY VARIABLES **'//' RCH ELE',
     1 14X,'CM-1   CM-2   CM-3',81X,'ANC'/' NUM NUM',7X,'TEMP',
     1 3(3X,A4),'     DO    BOD   ORGN   NH3N   NO2N   NO3N',
     2'  SUM-N   ORGP  DIS-P  SUM-P   COLI',3X,A4,'   CHLA')
6031    FORMAT(14X,'DEG-C',3(3X,A4),10(3X,'MG/L'),
     1' #/100ML',2X,A4,'   UG/L'/)
6030    FORMAT(14X,'DEG-F',3(3X,A4),10(3X,'MG/L'),
     1' #/100ML',2X,A4,'   UG/L'/)
6035    FORMAT(2I4,4X,14F7.2,E7.2,2F7.2)
6039    FORMAT( / 59X,'** ALGAE DATA **'//
     1 78X,'NH3-N',12X,'ALGAE GROWTH RATE ATTEN FACTORS'/
     2 ' ELE RCH ELE',11X,3(4X,'ALGY'),3X,'A P/R',5X,'NET',
     3 9X,'NH3   FRACT   LIGHT'/
     4 ' ORD NUM NUM',7X,'CHLA   GRWTH    RESP    SETT   ',
     5 'RATIO     P-R',8X,'PREF  N-UPTKE  EXTCO',8X,
     6 'LIGHT   NITRGN   PHSPRS')
6040    FORMAT(19X,'UG/L',2(3X,'1/DAY'),3X,'FT/DA',6X,
     1 '*   MG/L-D',3X,2(7X,'*'),5X,'1/FT',3X,3(8X,'*')/)
6041    FORMAT(19X,'UG/L',2(3X,'1/DAY'),3X,'M/DAY',6X,
     1 '*   MG/L-D',3X,2(7X,'*'),6X,'1/M',3X,3(8X,'*')/)
6045    FORMAT(3I4,3X,6F8.2,4X,3F8.2,4X,3F9.2)
6049    FORMAT(/54X,'** DISSOLVED OXYGEN DATA **'//
     1 67X,'COMPONENTS OF DISSOLVED OXYGEN MASS BALANCE (MG/L-DAY)',
     2/' ELE RCH ELE',14X,'DO',14X,'DO',5X,'DAM',5X,'NIT'/
     3 ' ORD NUM NUM    TEMP',5X,'SAT',6X,'DO',5X,'DEF   INPUT',
     4 3X,'INHIB',6X,'F-FNCTN   OXYGN',21X,'NET')
6050    FORMAT(15X,'DEG-F',4(4X,'MG/L'),4X,'FACT',8X,'INPUT',
     1 3X,'REAIR   C-BOD     SOD     P-R   NH3-N   NO2-N'/)
6051    FORMAT(15X,'DEG-C',4(4X,'MG/L'),4X,'FACT',8X,'INPUT',
     1 3X,'REAIR   C-BOD     SOD     P-R   NH3-N   NO2-N'/)
6055    FORMAT(3I4,6F8.2,5X,7F8.2)
        END
      SUBROUTINE PRPLOT (KDATA)
CC
C
C       FILE: 'MAIN.VAR'             ASCALR COMMON BLOCK FOR QUAL2E
C
C               ADD PARAMETER STATEMENTS TO CONTROL THE STORAGE
C               REQUIREMENTS FOR LARGE/SMALL SIMULATIONS
C
C               MC                      MAX # OF COMP ELEMENTS
C               MH                      MAX # OF HEADWATERS
C               MIRCH = 10 * MR         MAX SIZE OF IRCHNO ARRAY
C               MJ    = MH - 1          MAX # OF JUNCTIONS
C               ML>= MAX0(MR+1,MW+1,19) MAX SIZE OF DATA ARRAY
C               MR                      MAX # OF REACHES
C               MW                      MAX # OF WASTE LOADS
C               MNUDAM                  MAX # OF DAMS
C               LPPG  =  MAX NUMBER OF DATA LINES PER OUTPUT PAGE
C
C               IN QUAL2 SEMCOG, MC=500, MH=15, MJ=15, MR=75, MW=90
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C + Possible PARAMETER statements for smaller or larger simulations.
C
C       CEAM, standard PARAMETER statements
C       Date: Wednesday, 20 November 1991.  Time: 10:56:32.
C       ---------------------------------------------------
C       PARAMETER (MC=250,MH=10,ML=26,MR=25,MW=25,MNUDAM=25)
C       PARAMETER (MC=500,MH=20,ML=51,MR=50,MW=50,MNUDAM=25)
C
C       Kreider, State of Wisconsin
C       Date: Friday, 27 September 1991.  Time: 11:06:01.
C       -------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=51,MR=50,MW=50,MNUDAM=10)
C
C       Mangles, State of North Carolina
C       Date: Wednesday, 20 November 1991.  Time: 10:53:24.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=20,ML=101,MR=100,MW=100,MNUDAM=10)
C       Date: Thursday, 18 March 1993.  Time: 12:50:46.
C       ---------------------------------------------------
C       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=10)
C
C       Turner, State of South Carolina
C       Date: Friday, 22 November 1991.  Time: 12:53:51.
C       ---------------------------------------------------
C       PARAMETER (MC=500,MH=10,ML=61,MR=60,MW=50,MNUDAM=10)
C +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
       PARAMETER (MC=2000,MH=20,ML=201,MR=200,MW=200,MNUDAM=25)
       PARAMETER (MIRCH=10*MR)
       PARAMETER (MJ=MH-1)
C
        PARAMETER (LPPG=46)
C        PARAMETER (LPPG=31)
C
        REAL            KBOD,KNITRF,LAT,LLM,LSM
C
C                   MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ASCALU/ AE,BE,DAT,WETBLB,DRYBLB,CLOUD,ATMPR,WIND,
     *                  ALPHA5,ALPHA6,ALPHA3,ALPHA4,ALPHA1,ALPHA2,
     *                  GROMAX,RESPRT,CKN,CKP,EXALG1,EXALG2,
     *                  CKL,AFACT,DLH,SONET,PREFN,
     *                  TFACT,KNITRF,KBOD,THETA(19),LAVOPT,LFNOPT,
     *                  LGROPT
        COMMON /ASCALR/ AF,ALGLB,
     *                  ANCLB,BADLH,BASNET,BODLB,
     *                  CNH2LB,CNH3LB,CNO2LB,CNO3LB,COLILB,D1LT,
     *                  D2LT,DAYOFY,DELT,DELX,DEWPT,DOLB,
     *                  DT2ODX,DTODX2,ELEV,
     *                  LAT,LLM,LSM,PHOSLB,PORGLB,PTIME,
     *                  RF,SOLHR,TEMPLB,TIME,
     *                  TOFDAY,TPRINT,TRLCD,TSOLHR,
     *                  IPLOT,ISS,ITEMP,ITRAP,JPASS,LBFLG,
     *                  METOUT,METRIC,NC,NCS,NDAM,NHWTRS,
     *                  NJUNC,NREACH,NT,NWASTE
        COMMON /PCNTRL/ TMAX,
     *                  IAGIT,IAUGOP,IDATA,IDATA1,ILIST,
     *                  INTOUT,IPASS,IRPT1,
     *                  ITCODE,ITER,ITERN,ITERO,JTER,NCELLS,NERROR,
     *                  NITER,NTITLE
C3P1                                ,IFGRVT
C
C +++++ Named COMMON block DURNLT added by D. Disney of CSC 8/14/87
C +++++ Modified on - Date: Tuesday, 11 June 1991.  Time: 16:25:26.
C
        COMMON /DURNLT/ STS,STB,STR,DELTSL,EQTIME,SOLCON,RR,CON2,
     *                  DELLIN,CON6,CON5,PI,ELEXP,CON3,NL,CS,VPAIR,
     *                  CON1, CON4, EXEXP, DECLIN, STE, RS, ALPHA,
     *                  REARTH, DECLON, TANA, TANB, ACS, ATC, SOLAR,
     *                  XX
C
        SAVE /ASCALU/,/ASCALR/,/PCNTRL/,/DURNLT/

C
C       FILE: 'ARRAYS.VAR'           ARRAYS COMMON BLOCK FOR QUAL2E
C
C                 MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /ARRAYU/ ADAM(MNUDAM),BDAM(MNUDAM),FDAM(MNUDAM)
C
        COMMON /ARRAYS/ BATSUN(25),CONSLB(3),DAMO2(MNUDAM),
CBR     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(25),
     *                  HDAM(MNUDAM),R(25),SUN(25),TDLH(MR),
     *                  MODOPT(10)
        COMMON /TEMPLN/ ALFA1(21),ALFA2(21),BETA1(21),BETA2(21)
C3P1
        COMMON /OUTPLT/ OSIM(MC,85)
        SAVE /ARRAYU/,/ARRAYS/,/TEMPLN/,/OUTPLT/

C       INCLUDE 'CHARCT.VAR'
C
C       FILE: 'COMPRT.VAR'           COMPRT COMMON BLOCK FOR QUAL2E
C
        REAL            K1,K2,K3,K5,KANC,KNH2,KNH3,KNO2,KPORG
C
C         MODIFY FOR QUAL2E UNCERTAINTY
C
        COMMON /COMPRU/ FLOW(MC),VEL(MC),TRVTM(MC),DEPTH(MC),
     *                  EWIDTH(MC),VOLSEG(MC),BAREA(MC),XAREA(MC),
     *                  DL(MC),XK2(MC),CORDO(MC),
     *                  T(MC),CONS(MC,3),DO2(MC),BOD(MC),
     *                  CNH2(MC),CNH3(MC),CNO2(MC),
     *                  CNO3(MC),SUMN(MC),PORG(MC),PHOS(MC),SUMP(MC),
     *                  COLI(MC),ANC(MC),ALGAE(MC),
     *                  GROWTH(MC),APR(MC),APMR(MC),PRF(MC),EXTC(MC),
     *                  AGFL(MC),AGFN(MC),AGFP(MC)
        COMMON /COMPRT/ A(MC),AGYSET(MC),B(MC),C(MC),
     *                  DOSAT(MC),DTOVCL(MC),
     *                  G(MC),HSNET(MC),K1(MC),
     *                  K2(MC),K3(MC),K5(MC),KANC(MC),KNH2(MC),KNH3(MC),
     *                  KNO2(MC),KPORG(MC),
     *                  RESPRR(MC),S(MC),SCPHOS(MC),SETNH2(MC),
     *                  SOD(MC),SRANC(MC),SRCNH3(MC),
     *                  STANC(MC),STPORG(MC),
     *                  W(MC),
     *                  X(MC),Z(MC),JDAM(MC),JT(MC)
C
       SAVE /COMPRU/,/COMPRT/

C       INCLUDE 'HDWTRS.VAR'
C       INCLUDE 'JUNCTS.VAR'
C
C       FILE: 'REACHS.VAR'           REACHS COMMON BLOCK FOR QUAL2E
C
C          MODIFY FOR UNCERTAINTY ANALYSIS
C
        COMMON /REACHU/ DISKO(MR),COEFQV(MR),EXPOQV(MR),COEFQH(MR),
     *                  EXPOQH(MR),CMANN(MR),RCHELV(MR),RCHDAC(MR),
     *                  RCHCLD(MR),RCHTDB(MR),RCHTWB(MR),RCHATM(MR),
     *                  RCHWND(MR),RCHSAT(MR),RCHSOL(MR)
        COMMON /REACHR/ CK1(MR),CK3(MR),CK4(MR),CK2(MR),
     *                  COEQK2(MR),EXPQK2(MR),CKNH2(MR),SVNH2(MR),
     *                  CKNH3(MR),SNH3(MR),CKNO2(MR),CKPORG(MR),
     *                  SVPORG(MR),SPHOS(MR),ALPHAO(MR),ALGSET(MR),
     *                  EXCOEF(MR),CK5(MR),CKANC(MR),SETANC(MR),
     *                  SRCANC(MR),TINIT(MR),K2OPT(MR)
        COMMON /REACHI/ QI(MR),TI(MR),DOI(MR),BODI(MR),CONSI(MR,3),
     *                  ANCI(MR),COLIR(MR),ALGI(MR),CNH2I(MR),CNH3I(MR),
     *                  CNO2I(MR),CNO3I(MR),PORGI(MR),PHOSI(MR)
        COMMON /REACHS/ ALGIT(MR),ANCIT(MR),BOINIT(MR),
     *                  CNH2IT(MR),CNH3IT(MR),CNO2IT(MR),
     *                  CNO3IT(MR),COINIT(MR,3),COLIIT(MR),
     *                  DOINIT(MR),PHOSIT(MR),PORGIT(MR),
     *                  RMTEOR(MR),RMTHOR(MR),TARGDO(MR),TSONET(MR),
     *                  TSUN(MR,25),
     *                  IAUGOR(MR,6),ICLORD(MR,20),IFLAG(MR,20),
     *                  IRCHNO(MIRCH),NCELRH(MR),NHWWAR(MR)
C
      DIMENSION SS1(MR),SS2(MR),WIDTH(MR),SLOPE(MR)
C
      EQUIVALENCE (COEFQV(1),SS1(1)),(EXPOQV(1),SS2(1))
      EQUIVALENCE (COEFQH(1),WIDTH(1)),(EXPOQH(1),SLOPE(1))
C
      SAVE /REACHU/,/REACHR/,/REACHI/,/REACHS/

C       INCLUDE 'WASTLD.VAR'
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

CC
      CHARACTER*4       BEGI,CONTRL
      CHARACTER         LINE(81),ATITLE(29),BTITLE(29),ABLANK,BLANK,
     *                  ASTRSK,ADOT,EQUAL,APLUS,AMINUS,DOLLAR,P1,P2,P3
      DIMENSION         PDO(MC),PBOD(MC),NPRCH(MR)
      DIMENSION PMIN(40),PAVG(40),PMAX(40),DLOC(40),ILOC(MC)
C//   REAL LINE
      DATA BLANK,ASTRSK,ADOT,EQUAL,APLUS,AMINUS,DOLLAR
     *     /' ',   '*',  '.', '=',  '+',   '-',  '$'/
      DATA ATITLE/'R',' ','I',' ','V',' ','E',' ','R',' ',' ',' ',
     *            'M',' ','I',' ','L',' ','E',10*' '/
      DATA BTITLE/'R',' ','I',' ','V',' ','E',' ','R',' ',' ',' ','K',
     *  ' ','I',' ','L',' ','O',' ','M',' ','E',' ','T',' ','E',' ',
     *  'R'/
      DATA BEGI / 'BEGI' /
      DATA P1,P2,P3/'I','O','I'/
C
C                                       EXTRACT AND STORE DO AND
C                                       BOD VECTORS.
C3P1    OUTPUT INTERFACE
      NPLOT=1
C3P1
C3.0
10    CONTINUE
      READ(NI,25,ERR=10,END=99) CONTRL,ISTRCH
      IF(CONTRL.NE.BEGI) GO TO 10
      READ(NI,26) (NPRCH(I),I=1,NREACH)
   25 FORMAT(A4,6X,I5)
26    FORMAT(10X,14I5)
      IF(KDATA.EQ.0) GO TO 53
C3.0
C3.0     READ OBSERVED DO DATA
C3.0
      READ(NI2,50,END=53) NOB
      DO 51 I=1,NOB
      READ(NI2,52) DLOC(I),PMIN(I),PAVG(I),PMAX(I)
      IF(PAVG(I).LE.0.0) PAVG(I) = PMIN(I)
      IF(PMAX(I).LE.0.0) PMAX(I) = PMIN(I)
51    CONTINUE
50    FORMAT(10X,I4)
52    FORMAT(10X,4F10.0)
C3.0
C3.0      END OBSERVED DO DATA READ
C3.0
53    CONTINUE
C3.0
      IPOR=0
      KPP=0
      KP=0
C
C3.0    MODIFICATIONS FOR PLOTTING OBSERVED DATA
C
      BEGLOC = RMTHOR(ISTRCH)
      DX = DELX/5280.
      IF(METRIC.LT.1) GO TO 47
      BEGLOC = BEGLOC*1.609
      DX =DX*1.609
      GO TO 47
47    CONTINUE
      XLOC = BEGLOC
C
      N=1
      JD = 0
      DMIN = 100.
      DMAX = -10.
      DAVG = 0.0
C3.0
      DO 100 I=1,NREACH
      II=NPRCH(I)
      IF (II.EQ.0) GO TO 100
      NCELR=NCELRH(I)
      DO 90 J=1,NCELR
      IOR=ICLORD(I,J)
C3P1   OUTPUT INTERFACE
      OSIM(IOR,4) = NPLOT
C3P1
      IPOR=IPOR+1
      PDO(IPOR)=DO2(IOR)
      PBOD(IPOR)=BOD(IOR)
C
C3.0   MODIFICATIONS FOR PLOTTING OBSERVED DATA
C
      IF(KDATA.EQ.0) GO TO 90
      XL1 = XLOC + DX/100.
      XL2 = XL1-DX
      ILOC(IPOR) = 0
      IF(N.GT.NOB) GO TO 90
65    IF(XL1.GE.DLOC(N).AND.XL2.LT.DLOC(N)) GO TO 60
      IF(JD.EQ.0) GO TO 89
      PMIN(N-1) = DMIN
      PMAX(N-1) = DMAX
      PAVG(N-1) = DAVG/JD
      JD=0
      DMIN = 100.
      DMAX = -10.
      DAVG = 0.0
      GO TO 89
C
C     DATA POINT LOCATED IN THIS COMP. ELE.
C
60    ILOC(IPOR) = N
      IF(PMIN(N).LT.DMIN) DMIN = PMIN(N)
      IF(PMAX(N).GT.DMAX) DMAX = PMAX(N)
      DAVG = DAVG + PAVG(N)
      N = N + 1
      JD = JD + 1
C
C      LOOP TO CHECK FOR ANOTHER DATA POINT IN THIS COMP. ELE.
C
      GO TO 65
89    XLOC = XLOC - DX
   90 CONTINUE
  100 CONTINUE
      XLOC=BEGLOC
      XX=(IPOR-30)/2.0
      IF(XX.LT.0.0) XX=0.0
      KX=XX+1
      KXX=XX+30
C
C                                       PRINT FIRST ORDINATE AXIS
C                                       AND CORRESPONDING LABELS.
C
      WRITE (NJ,1)
    1 FORMAT (1H1,36X,43HD I S S O L V E D  O X Y G E N  ( M G / L ))
      WRITE (NJ,2)
    2 FORMAT (16X,43H0.0     1.0     2.0     3.0     4.0     5.0,
     *         5X,35H6.0     7.0     8.0     9.0    10.0)
C
C                                       PRINT DO AND BOD PLOTS.
C
      DO 200 I=1,IPOR
      IF (I.LT.KX.OR.I.GT.KXX) GO TO 33
      KPP=KPP+1
      IF(KPP.GE.29) KPP=29
      ABLANK=ATITLE(KPP)
CBR      IF(METRIC.GE.1) ABLANK = BTITLE(KPP)
      IF(METOUT.GE.1) ABLANK = BTITLE(KPP)
      GO TO 34
   33 ABLANK=BLANK
   34 CONTINUE
      IF (I.NE.1) GO TO 601
  602 KP=KP+1
      DO 300 J=1,81
      LINE(J)=APLUS
  300 CONTINUE
      GO TO 700
  601 IF (I.EQ.IPOR) GO TO 602
      GO TO 603
  606 KP=KP+1
      KPPP=8
      DO 800 J=1,81
      IF (KPPP.EQ.8) GO TO 803
      KPPP=KPPP+1
      LINE(J)=BLANK
      GO TO 800
  803 KPPP=1
      LINE(J)=APLUS
  800 CONTINUE
      GO TO 700
  603 IF (I.LE.4.OR.I.GE.(IPOR-3)) GO TO 606
C +++++
C  604 IF (KP.NE.10) GO TO 605
      IF (KP.NE.10) GO TO 605
C +++++
      KP=1
      DO 310 J=1,5
      LINE(J)=APLUS
  310 CONTINUE
      DO 311 J=6,76
      LINE(J)=BLANK
  311 CONTINUE
      DO 312 J=77,81
      LINE(J)=APLUS
  312 CONTINUE
      GO TO 700
  605 LINE(1)=APLUS
      KP=KP+1
      DO 313 J=2,80
      LINE(J)=BLANK
  313 CONTINUE
      LINE(81)=APLUS
  700 CONTINUE
      DOJ=8.0*PDO(I)
      BODJ=1.6*PBOD(I)
C3.0
      IF(DOJ.GE.80.) DOJ=80.
      IF(BODJ.GE.80.) BODJ=80.
C3.0
      J=DOJ
      K=BODJ
      LINE(J+1)=ASTRSK
      LINE(K+1)=ADOT
C3.0
      IF(J.EQ.80) LINE(J+1)=DOLLAR
      IF(K.EQ.80) LINE(K+1)=DOLLAR
C3.0
      IF (J.EQ.K) LINE(J+1)=EQUAL
C
C3.0   PLOT OBSERVED DATA
C
      IF(KDATA.EQ.0) GO TO 80
      IF(ILOC(I).EQ.0) GO TO 80
      N = ILOC(I)
      J1 = PMIN(N)*8.0
      J2 = PAVG(N)*8.0
      J3 = PMAX(N)*8.0
      IF(J1.GE.80) J1 = 80
      IF(J2.GE.80) J2 = 80
      IF(J3.GE.80) J3 = 80
      JA = J3-J1
      IF(JA.LE.1) GO TO 71
      DO 70 M1 = J1+2,J3
70    LINE(M1) = AMINUS
71    CONTINUE
      LINE(J2+1) = P2
      LINE(J1+1) = P1
      LINE(J3+1) = P3
80    CONTINUE
C
      IF (I.EQ.1.OR.I.EQ.IPOR) GO TO 825
      IF (KP.EQ.1) GO TO 825
      WRITE (NJ,5) ABLANK,(LINE(J),J=1,81)
    5 FORMAT (9X,A1,7X,81A1)
      GO TO 199
  825 CONTINUE
      WRITE (NJ,4) ABLANK,XLOC,(LINE(J),J=1,81)
    4 FORMAT (9X,A1,F6.1,1X,81A1)
199   CONTINUE
      XLOC = XLOC - DX
  200 CONTINUE
C
C                                       PRINT SECOND ORDINATE AXIS
C                                       AND CORRESPONDING LABELS.
C
      WRITE (NJ,6)
    6 FORMAT (16X,43H0.0     5.0    10.0    15.0    20.0    25.0,
     *         4X,36H30.0    35.0    40.0    45.0    50.0)
      WRITE (NJ,7)
    7 FORMAT (29X,47HB I O C H E M I C A L  O X Y G E N  D E M A N D,
     *         2X,11H( M G / L ))
      WRITE (NJ,266)
  266 FORMAT (//////25X,35HDISSOLVED OXYGEN          = * * * *)
      WRITE (NJ,267)
  267 FORMAT (1H0,25X,35HBIOCHEMICAL OXYGEN DEMAND = . . . .)
C3P1  OUTPUT INTERFACE
      NPLOT = NPLOT+1
      GO TO 10
99    CONTINUE
      CLOSE(UNIT=NI2)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE CLRSCR
C
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C
CTGC        WRITE(CONOUT,*)'PAGE'
CTGC      WRITE(CONOUT,*)' [2J'
CVAX
CVAX      CHARACTER CLR1(10)
CVAX      DATA CLR1 / ' ',27,'[','1',';','1','f',27,'[','J' /
CVAX      WRITE(CONOUT,10)CLR1
CVAX10    FORMAT(1X,10A1)
CVAX
CTGC      WRITE(*,*)'EXIT CLRSCR'
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE GETMSG (MSGNO,MSGFIL)
C
C +++++
C      INTEGER*2 LINES, MSGFIL, MSGNO, FMSGNO, CONOUT
      INTEGER LINES, MSGFIL, MSGNO, FMSGNO, CONOUT
C +++++
      CHARACTER*50 PRTTXT(24), FILTXT
C
CPC      DATA CONOUT / 7 /
CVAX      DATA CONOUT / 6 /
CSAL      DATA CONOUT / 6 /
CSVS      DATA CONOUT / 6 /
      DATA CONOUT / 6 /
C
      REWIND(UNIT=MSGFIL)
      LINES=0
C
  100 CONTINUE
      READ(UNIT=MSGFIL,FMT=800,ERR=991,END=500) FMSGNO, FILTXT
      IF(MSGNO.GT.FMSGNO) GO TO 100
      IF(MSGNO.LT.FMSGNO) GO TO 500
      LINES=LINES+1
      PRTTXT(LINES)=FILTXT
      GO TO 100
C
  500 CONTINUE
      IF(LINES.NE.0) CALL PRTMSG(LINES,PRTTXT)
      GO TO 999
C
  991 CONTINUE
      CALL CLRSCR
      WRITE(CONOUT,9991) MSGFIL
C
CTGC  999 WRITE(*,*)'EXIT GETMSG'
  999 RETURN
C
  800 FORMAT(I2,1X,A50)
 9991 FORMAT(1X,///////////,10X,' ERROR:  Fatal error reading',
     1       ' message file assigned to unit ',I2)
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE PRTMSG (LINES,PRTTXT)
C
C
C       FILE: 'IOUNIT.INC'      I/O UNIT NUMBER COMMON BLOCK FOR QUAL2E
C
C
C +++++
C        INTEGER*2       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
C     1                  IM, IU, SUPFIL, NJ4
        INTEGER       CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                IM, IU, SUPFIL, NJ4
C +++++
C
        COMMON /IOUNIT/ CONIN, CONOUT, MSGFIL, CFGFIL, NI, NJ, NI2, NJ2,
     1                  IM, IU, SUPFIL, NJ4
C

C     These COMMON block allows for the storage of machine dependent
C     numeric constants.
C
      INTEGER          RPREC,DPREC
      REAL             R0MIN,RP1MIN,R0MAX
      DOUBLE PRECISION D0MIN,DP1MIN,D0MAX
C
      COMMON /ICONST/ RPREC,DPREC
      COMMON /RCONST/ R0MIN,RP1MIN,R0MAX
      COMMON /DCONST/ D0MIN,DP1MIN,D0MAX
C
C     RPREC  - the number of (decimal) digits of precision of a real number.
C     DPREC  - the number of (decimal) digits of precision of a double.
C     R0MIN  - the smallest (positive) representable real number.
C     RP1MIN - the minimum representable real number greater than (plus) 1.0.
C     R0MAX  - the largest representable real number.
C     D0MIN  - the smallest (positive) representable double.
C     DP1MIN - the minimum representable double greater than (plus) 1.0.
C     D0MAX  - the largest representable double.

C
C +++++
C      INTEGER*2 LINES, SKPLIN, SPACES, BUFFER, I, J
      INTEGER LINES, SKPLIN, SPACES, BUFFER, I, J
C +++++
      CHARACTER*50 PRTTXT(24), FILTXT
      CHARACTER*54 TXTOUT
C
      TXTOUT='*                                                    *'
C
      CALL CLRSCR
      SKPLIN=(24-2-LINES)/2
C
      A=FLOAT(LINES)
      B=A/2.0
      J=LINES/2
      C=FLOAT(J)
C +++++
C      IF (B.NE.C) SKPLIN=SKPLIN+1
      RDIFF=B-C
      IF (ABS(RDIFF).GT.R0MIN) SKPLIN=SKPLIN+1
C +++++
C
      DO 100 I=1,SKPLIN-1
  100    WRITE(CONOUT,*)'  '
C
      WRITE(CONOUT,600)
C
      DO 200 I=1,LINES
         TXTOUT(2:53)=' '
         FILTXT=PRTTXT(I)
         DO 210 J=50,1,-1
  210       IF(FILTXT(J:J).NE.' ') GO TO 300
         SPACES=0
         GO TO 400
  300    SPACES=51-J
  400    BUFFER=3+(SPACES/2)
         TXTOUT(BUFFER:52)=FILTXT
         WRITE(CONOUT,610) TXTOUT
  200 CONTINUE
C
      WRITE(CONOUT,600)
C
      DO 500 I=1,SKPLIN-1
  500    WRITE(CONOUT,*)'  '
C
      RETURN
C
  600 FORMAT(13X,54('*'))
  610 FORMAT(1X,12X,A54)
C
      END

