c Copyright (C) Stichting Deltares, 2005-2014.
c
c This file is part of iMOD.
c
c This program is free software: you can redistribute it and/or modify
c it under the terms of the GNU General Public License as published by
c the Free Software Foundation, either version 3 of the License, or
c (at your option) any later version.
c
c This program is distributed in the hope that it will be useful,
c but WITHOUT ANY WARRANTY; without even the implied warranty of
c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
c GNU General Public License for more details.
c
c You should have received a copy of the GNU General Public License
c along with this program. If not, see .
c
c Contact: imod.support@deltares.nl
c Stichting Deltares
c P.O. Box 177
c 2600 MH Delft, The Netherlands.
c
c iMod is partly based on the USGS MODFLOW2005 source code;
c for iMOD the USGS MODFLOW2005 source code has been expanded
c and extensively modified by Stichting Deltares.
c The original USGS MODFLOW2005 source code can be downloaded from the USGS
c website http://www.usgs.gov/. The original MODFLOW2005 code incorporated
c in this file is covered by the USGS Software User Rights Notice;
c you should have received a copy of this notice along with this program.
c If not, see .
C
C-------SUBROUTINE GWF2SFR7AR
SUBROUTINE GWF2SFR7AR(In, Iunitbcf, Iunitlpf, Iunithuf, Iunitgwt,
+ Nsol, Iouts, Igrid)
C ******************************************************************
C ALLOCATE ARRAY STORAGE FOR STREAMS
C INITIALIZE VARIABLES FOR SFR PACKAGES
C READ STREAM DATA THAT IS CONSTANT FOR ENTIRE SIMULATION:
C REACH DATA AND PARAMETER DEFINITIONS
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
C SPECIFICATIONS:
C ------------------------------------------------------------------
USE GWFSFRMODULE
USE GLOBAL, ONLY: IOUT, IBOUND, BOTM, STRT, DELR, DELC,
+ ITRSS
USE GWFLPFMODULE, ONLY: SC2LPF=>SC2
USE GWFBCFMODULE, ONLY: SC1, SC2, LAYCON
USE GWFHUFMODULE, ONLY: SC2HUF
IMPLICIT NONE
INTRINSIC ABS, DBLE
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER In, Iunitbcf, Iunitlpf, Iunithuf, Iunitgwt, Nsol, Iouts,
+ Igrid
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
CHARACTER*200 line
INTEGER lloc, istart, istop, nparseg, i, ii, nlst, lb, ichk, icalc
INTEGER nseg, nreach, krch, irch, jrch, jseg, ireach, ksfropt
INTEGER krck, irck, jrck, jsegck, ireachck, kkptflg, ib
INTEGER lstsum, lstbeg, numinst, idum(1), ip, iterp, mstrmar
INTEGER nssar, nstrmar, nsegdim
REAL r, seglen, sumlen, thsslpe, thislpe, uhcslpe, rchlen, dist
REAL epsslpe
C ------------------------------------------------------------------
Version_sfr =
+'$Id: gwf2sfr7.f 1128 2009-09-28 22:25:56Z rniswon $'
iterp = 1
idum(1) = 0
ALLOCATE (NSS, NSTRM,TOTSPFLOW)
ALLOCATE (NSFRPAR, ISTCB1, ISTCB2, IUZT, MAXPTS)
ALLOCATE (ISFROPT, NSTRAIL, ISUZN, NSFRSETS)
ALLOCATE (NUZST, NSTOTRL, NUMAVE)
ALLOCATE (ITMP, IRDFLG, IPTFLG, NP)
ALLOCATE (CONST, DLEAK, IRTFLG, NUMTIM, WEIGHT, FLWTOL)
ALLOCATE (SFRRATIN, SFRRATOUT)
ALLOCATE (STRMDELSTOR_CUM, STRMDELSTOR_RATE)
C1------IDENTIFY PACKAGE AND INITIALIZE NSTRM.
WRITE (IOUT, 9001) In
9001 FORMAT (1X, /, ' SFR7 -- STREAMFLOW ROUTING PACKAGE, '
+ ,'VERSION 7.1.02, 06/29/2009', /, 9X,
+ 'INPUT READ FROM UNIT', I4)
C
C2------READ COMMENT RECORDS, NSTRM, NSS, NSFRPAR, NPARSEG, CONST,
C DLEAK, ISTCB1, ISTCB2.
CALL URDCOM(In, IOUT, line)
lloc = 1
ISFROPT = 0
IUZT = 0
IRTFLG = 0
NUMTIM = 1
FLWTOL = 1.0E-4
STRMDELSTOR_CUM = 0.0E0
STRMDELSTOR_RATE = 0.0E0
SFRRATIN = 0.0
SFRRATOUT = 0.0
TOTSPFLOW = 0.0D0
CALL URWORD(line, lloc, istart, istop, 2, NSTRM, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, NSS, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, NSFRPAR, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, nparseg, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 3, i, CONST, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 3, i, DLEAK, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, ISTCB1, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, ISTCB2, r, IOUT, In)
C
C3------READ ISFROPT FLAGS WHEN NSTRM IS LESS THAN ZERO.
IF ( NSTRM.LT.0 ) THEN
IF ( NSFRPAR.GT.0 ) THEN
WRITE(IOUT, 9002)
9002 FORMAT (//, 'NSTRM IS NEGATIVE AND NSFRPAR IS GREATER THAN ',
+ 'ZERO ', /1X , ' ALTERNATE SFR7 OPTIONS DO NOT ',
+ 'SUPPORT PARAMETERS--PROGRAM STOPPING ',/)
CALL USTOP(' ')
END IF
NSTRM = ABS(NSTRM)
CALL URWORD(line, lloc, istart, istop, 2, ISFROPT, r, IOUT, In)
C
C4------READ UNSATURATED FLOW VARIABLES WHEN ISFROPT GREATER THAN 1.
IF ( ISFROPT.GE.2 ) THEN
IUZT = 1
CALL URWORD(line, lloc, istart, istop, 2, NSTRAIL, r, IOUT,
+ In)
CALL URWORD(line, lloc, istart, istop, 2, ISUZN, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 2, NSFRSETS, r, IOUT,
+ In)
END IF
!4b-----Data read for transient routing.
CALL URWORD(line, lloc, istart, istop, 2, IRTFLG, r, IOUT, In)
IF ( IRTFLG .GT. 0 ) THEN
NUMTIM = 1
WEIGHT = 1.0
FLWTOL = 1.0D-6
CALL URWORD(line, lloc, istart, istop, 2, NUMTIM, r, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 3, i, WEIGHT, IOUT, In)
CALL URWORD(line, lloc, istart, istop, 3, i, FLWTOL, IOUT, In)
IF ( NUMTIM.LT.1 ) NUMTIM = 1
IF ( WEIGHT.LT.0.0 .OR. WEIGHT.GT.1.0 ) WEIGHT=1.0
IF ( FLWTOL.LT.0.0 ) FLWTOL=0.0
ELSE
NUMTIM = 1
WEIGHT = 1.0
FLWTOL = 0.0
END IF
END IF
IF ( NSS.LT.0 ) NSS = 0
IF ( NSFRPAR.LE.0 ) THEN
NSFRPAR = 0
nparseg = 0
END IF
IF ( nparseg.LT.0 ) nparseg = 0
nssar = 1
IF (NSS.GT.0) nssar = NSS
nstrmar = 1
IF (NSTRM.GT.0) nstrmar = NSTRM
nsegdim = NSS + nparseg
IF (nsegdim.LT.1) nsegdim = 1
C
C5------CALCULATE SPACE NEEDED FOR TABULATED DISCHARGE VERSUS FLOW
C AND WIDTH RELATIONS.
MAXPTS = 3*50
C
C ******************************************************************
C ALLOCATE ARRAY STORAGE FOR STREAMS
C ******************************************************************
C
Cdep changed DSTROT to FXLKOT
ALLOCATE (STRIN(nssar), STROUT(nssar), FXLKOT(nssar))
STRIN = 0.0
STROUT = 0.0
FXLKOT = 0.0
ALLOCATE (STRM(30,nstrmar), ISTRM(5,nstrmar))
ALLOCATE (HSTRM(nstrmar,NUMTIM), HWDTH(nstrmar,NUMTIM))
ALLOCATE (QSTRM(nstrmar,NUMTIM))
ALLOCATE (HWTPRM(nstrmar,NUMTIM))
STRM = 0.0
HSTRM = 0.0
QSTRM = 0.0
HWDTH = 0.0
HWTPRM = 0.0
ISTRM = 0
ALLOCATE (SEG(26,nsegdim), ISEG(4,nsegdim), IDIVAR(2,nsegdim))
Cdep allocate space for stream outflow derivatives for lake package
ALLOCATE (DLKOTFLW(200,nssar), SLKOTFLW(200,nssar))
ALLOCATE (DLKSTAGE(200,nssar))
SEG = 0.0
ISEG = 0
IDIVAR = 0
DLKOTFLW = 0.0D0
DLKSTAGE = 0.0D0
SLKOTFLW = 0.0D0
ALLOCATE (IOTSG(nsegdim))
IOTSG = 0
ALLOCATE (SFRQ(5,nstrmar))
SFRQ = 0.0
IF ( Iunitgwt.GT.0 ) THEN
ALLOCATE (CONCQ(nsegdim,Nsol), CONCRUN(nsegdim,Nsol))
ALLOCATE (CONCPPT(nsegdim,Nsol))
ELSE
ALLOCATE (CONCQ(1,Nsol), CONCRUN(1,Nsol), CONCPPT(1,Nsol))
END IF
C
C6------PRINT INFORMATION THAT WAS READ.
WRITE (IOUT, 9003) NSTRM, NSS, NSFRPAR, nparseg, DLEAK, CONST
IF ( ISFROPT.EQ.1 ) WRITE (IOUT, 9004)
IF ( ISFROPT.GE.2 ) WRITE (IOUT, 9005)
IF ( ISTCB1.GT.0 ) WRITE (IOUT, 9006) ISTCB1
IF ( ISTCB2.GT.0 ) WRITE (IOUT, 9007) ISTCB2
IF ( IRTFLG.GT.0 ) WRITE (IOUT, 9035)
9003 FORMAT (//, ' NUMBER OF STREAM REACHES IS', I5, //,
+ ' NUMBER OF STREAM SEGMENTS IS', I5, //,
+ ' NUMBER OF STREAM PARAMETERS IS', I5, //,
+ ' NUMBER OF STREAM SEGMENTS DEFINED USING PARAMETERS IS',
+ I5, //, ' MAXIMUM ERROR FOR STREAM LEAKAGE RATES IS',
+ 1PE10.2, //, ' CONSTANT FOR MANNINGS EQUATION IS', E12.4,
+ ///)
9004 FORMAT (//, ' USING DATA INPUT MODIFIED FROM ORIGINAL SFR ',
+ 'PROGRAM FOR FARM PACKAGE', /)
9005 FORMAT (//, ' OPTION FOR UNSATURATED FLOW BENEATH STREAMBEDS IS ',
+ 'ACTIVE ', //)
9006 FORMAT (' FLOW TO AND FROM GROUND WATER FOR EACH STREAM REACH ',
+ 'WILL BE SAVED ON UNIT', I3)
9007 FORMAT (' STREAM OUTPUT WILL BE WRITTEN TO FILE ON UNIT', I4)
9035 FORMAT (' TRANSIENT STREAMFLOW ROUTING IS ACTIVE ')
C
C7------CHECK FOR ERRORS.
IF ( NSTRM.LE.0 .OR. NSS.LE.0 ) THEN
WRITE (IOUT, 9008)
In = 0
NSS = 0
NSTRM = 0
RETURN
END IF
IF ( NSFRPAR.GT.0 .AND. nparseg.LE.0 ) THEN
WRITE (IOUT, 9009)
In = 0
NSS = 0
NSTRM = 0
RETURN
END IF
IF ( IUZT.EQ.1 ) THEN
IF ( NSTRAIL.LT.0 ) THEN
WRITE (IOUT, 9010)
NSTRAIL = ABS(NSTRAIL)
END IF
IF ( NSTRAIL.EQ.0 ) THEN
WRITE (IOUT, 9011)
IUZT = 0
END IF
END IF
IF ( DLEAK.LE.0.0 ) THEN
DLEAK = 0.00001
WRITE (IOUT, 9012)
END IF
9008 FORMAT (//, ' NO STREAM REACHES (NSTRM) AND/OR SEGMENTS (NSS)--',
+ //, ' SFR PACKAGE BEING TURNED OFF'///)
9009 FORMAT (//, ' NO STREAM SEGMENTS DEFINED BY PARAMETERS--',
+ 'NSFRPAR GT ZERO AND NPARSEG LE ZERO', //,
+ ' SFR PACKAGE BEING TURNED OFF'///)
9010 FORMAT (//, ' NUMBER OF TRAILING WAVES IS LESS THAN ZERO',
+ '--SETTING VALUE TO A POSITIVE VALUE'///)
9011 FORMAT (//, ' VERTICAL FLOW THROUGH UNSATURATED ZONE IS ',
+ 'ACTIVE AND NUMBER OF TRAILING WAVES IS ZERO-- ',
+ ' RESETTING UNSATURATED FLOW TO BE INACTIVE '///)
9012 FORMAT (//, ' *** WARNING *** DLEAK IS LESS THAN OR EQUAL',
+ ' TO ZERO --- DLEAK ASSIGNED A VALUE OF 0.0001', ///)
C
IF ( IUZT.EQ.1 ) THEN
C
C8------ALLOCATE SPACE FOR UNSATURATED FLOW.
NUZST = NSTRM
NSTOTRL = ISUZN*NSTRAIL*NSFRSETS
NUMAVE = 21
mstrmar = nstrmar
ELSE
C
C9------ALLOCATE ONLY ONE ARRAY ELEMENT IF UNSATURATED FLOW IS INACTIVE.
NUZST = 1
NSTOTRL = 1
NUMAVE = 1
ISUZN = 1
NSTRAIL = 1
NSFRSETS = 1
mstrmar = 1
END IF
C
C ALLOCATE AND INITIALIZE ARRAYS
C
ALLOCATE (THTS(NUZST), THTR(NUZST), THTI(NUZST), EPS(NUZST))
THTS = 0.0D0
THTR = 0.0D0
THTI = 0.0D0
EPS = 0.0D0
ALLOCATE (UHC(NUZST))
UHC = 0.0
ALLOCATE (XSEC(16, nsegdim), QSTAGE(MAXPTS,nsegdim))
XSEC = 0.0
QSTAGE = 0.0
ALLOCATE (NSEGCK(nssar), SGOTFLW(nssar), DVRSFLW(nssar))
NSEGCK = 0
SGOTFLW = 0.0
DVRSFLW = 0.0
ALLOCATE (SFRUZBD(10))
SFRUZBD = 0.0
C
C10-----READ AND PRINT DATA FOR EACH STREAM REACH.
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9013)
ELSE IF ( ISFROPT.EQ.1 ) THEN
WRITE (IOUT, 9014)
ELSE IF ( ISFROPT.EQ.2 ) THEN
WRITE (IOUT, 9015)
ELSE IF ( ISFROPT.EQ.3 ) THEN
WRITE (IOUT, 9016)
ELSE IF ( ISFROPT.EQ.4 ) THEN
WRITE (IOUT, 9013)
ELSE IF ( ISFROPT.EQ.5 ) THEN
WRITE (IOUT, 9013)
END IF
9013 FORMAT (1X, //, 3X, 'STREAM NETWORK DESCRIPTION: ', //, 3X,
+ 'LAYER ROW COL SEGMENT REACH LENGTH', /,
+ 26X, 'NUMBER NUMBER IN CELL', /, 3X, 50('-'))
9014 FORMAT (1X, //, 3X, 'STREAM NETWORK DESCRIPTION: ', //, 3X,
+ 'LAYER ROW COL SEGMENT REACH LENGTH',
+ ' STREAMBED STREAMBED STREAMBED STREAMBED',
+ /, 26X, 'NUMBER NUMBER IN CELL TOP ELEV. ',
+ ' SLOPE THICKNESS', ' HYDR. CONDUCT.', /, 3X,
+ 105('-'))
9015 FORMAT (1X, //, 3X, 'STREAM NETWORK DESCRIPTION: ', //, 3X,
+ 'LAYER ROW COL SEGMENT REACH LENGTH',
+ ' STREAMBED STREAMBED STREAMBED ',
+ 'STREAMBED SATURATED INITIAL',
+ ' RESIDUAL BROOKS/COREY', /, 20X,
+ 'NUMBER NUMBER IN CELL',
+ ' TOP ELEV. SLOPE THICKNESS ',
+ 'HYD. COND. WAT.CONT. WAT.CONT. ',
+ 'WAT.CONT. EPSILON', /, 3X, 150('-'))
9016 FORMAT (1X, //, 3X, 'STREAM NETWORK DESCRIPTION: ', //, 3X,
+ 'LAYER ROW COL SEGMENT REACH LENGTH ',
+ 'STREAMBED STREAMBED STREAMBED STREAMBED',
+ ' SATURATED INITIAL',
+ ' RESIDUAL BROOKS/COREY SAT. VERT.', /, 20X,
+ 'NUMBER NUMBER IN CELL ',
+ 'TOP ELEV. SLOPE THICKNESS ',
+ 'HYD. COND. WAT.CONT. WAT.CONT. ',
+ 'WAT.CONT. EPSILON HYD. COND.', /, 3X, 151('-'))
C
C11-----READ AND WRITE DATA FOR EACH REACH ON BASIS OF ISFROPT.
nseg = 0
nreach = 0
! IF ( Iunithuf.GT.0 ) THEN
! IF ( ISFROPT.NE.3 .AND. ISFROPT.NE.5 ) THEN
! WRITE (IOUT, 9034)
! 9034 FORMAT (//, ' ***ERROR*** HUF PACKAGE IS ACTIVE ',
! + 'AND ISFROPT NOT 3 or 5 ',/,
! + ' PROGRAM IS STOPPING')
! CALL USTOP(' ')
! END IF
! END IF
DO ii = 1, NSTRM
IF ( ISFROPT.EQ.0 ) THEN
READ (In, *) krch, irch, jrch, jseg, ireach, STRM(1, ii)
ELSE IF ( ISFROPT.EQ.1 ) THEN
READ (In, *) krch, irch, jrch, jseg, ireach, STRM(1, ii),
+ STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii)
STRM(4, ii) = STRM(3, ii) - STRM(8, ii)
IF ( STRM(2, ii).LE.0.0 ) THEN
WRITE (IOUT, 9017) jseg, ireach
CALL USTOP(' ')
END IF
ELSE IF ( ISFROPT.EQ.2 ) THEN
READ (In, *) krch, irch, jrch, jseg, ireach, STRM(1, ii),
+ STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii), THTS(ii), THTI(ii), EPS(ii)
STRM(4, ii) = STRM(3, ii) - STRM(8, ii)
IF ( STRM(2, ii).LE.0.0 ) THEN
WRITE (IOUT, 9017) jseg, ireach
CALL USTOP(' ')
END IF
ELSE IF ( ISFROPT.EQ.3 ) THEN
READ (In, *) krch, irch, jrch, jseg, ireach, STRM(1, ii),
+ STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii), THTS(ii), THTI(ii), EPS(ii), UHC(ii)
STRM(4, ii) = STRM(3, ii) - STRM(8, ii)
IF ( STRM(2, ii).LE.0.0 ) THEN
WRITE (IOUT, 9017) jseg, ireach
CALL USTOP(' ')
END IF
ELSE IF ( ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
READ (In, *) krch, irch, jrch, jseg, ireach, STRM(1, ii)
END IF
IF ( IUZT.EQ.1 ) THEN
IF ( STRT(jrch, irch, krch).LE.BOTM(jrch, irch, krch) )
+ WRITE (IOUT, 9018) ireach, jseg
END IF
9017 FORMAT (//, ' ***ERROR*** SLOPE IS SPECIFIED LESS THAN OR ',
+ 'EQUAL TO ZERO FOR SEGMENT', I8, ' REACH', I8, /,
+ ' PROGRAM IS STOPPING')
9018 FORMAT (5X, '**WARNING** CELL BENEATH STREAM REACH IS INACTIVE',
+ /, 5X, 'CELL BELOW MUST HAVE THE SAME SPECIFIC YIELD',
+ /, 5X, 'AND THE TOP ELEVATION OF ACTIVE CELL MUST ',
+ 'EQUAL BOTTOM OF INACTIVE CELL', /, 5X,
+ 'INACTIVE CELL IS BELOW STREAM REACH AND SEGMENT:', 2I5)
C
C12-----CALCULATE RESIDUAL WATER CONTENT FROM SATURATED WATER CONTENT
C AND SPECIFIC YIELD WHEN UNSATURATED FLOW IS ACTIVE.
IF ( ABS(ITRSS).EQ.1 ) THEN
IF ( ISFROPT.EQ.2 .OR. ISFROPT.EQ.3 ) THEN
IF ( Iunitlpf.GT.0 ) THEN
THTR(ii) = THTS(ii) - SC2LPF(jrch, irch, krch)
+ /(DELR(jrch)*DELC(irch))
ELSE IF ( Iunitbcf.GT.0 ) THEN
IF ( LAYCON(krch).EQ.1 ) THEN
THTR(ii) = THTS(ii) - SC1(jrch, irch, krch)
+ /(DELR(jrch)*DELC(irch))
ELSE
THTR(ii) = THTS(ii) - SC2(jrch, irch, krch)
+ /(DELR(jrch)*DELC(irch))
END IF
ELSE IF ( Iunithuf.GT.0 ) THEN
THTR(ii) = THTS(ii) - SC2HUF(jrch, irch)
END IF
END IF
ELSEIF ( ISFROPT.EQ.2 .OR. ISFROPT.EQ.3 ) THEN
THTR(ii) = 0.0
END IF
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9019) krch, irch, jrch, jseg, ireach, STRM(1, ii)
ELSE IF ( ISFROPT.EQ.1 ) THEN
WRITE (IOUT, 9020) krch, irch, jrch, jseg, ireach, STRM(1, ii)
+ , STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii)
ELSE IF ( ISFROPT.EQ.2 ) THEN
WRITE (IOUT, 9021) krch, irch, jrch, jseg, ireach, STRM(1, ii)
+ , STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii), THTS(ii), THTI(ii), THTR(ii),
+ EPS(ii)
ELSE IF ( ISFROPT.EQ.3 ) THEN
WRITE (IOUT, 9022) krch, irch, jrch, jseg, ireach, STRM(1, ii)
+ , STRM(3, ii), STRM(2, ii), STRM(8, ii),
+ STRM(6, ii), THTS(ii), THTI(ii), THTR(ii),
+ EPS(ii), UHC(ii)
ELSE IF ( ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
WRITE (IOUT, 9019) krch, irch, jrch, jseg, ireach, STRM(1, ii)
END IF
9019 FORMAT (2X, I5, 2I7, I8, I9, 3X, 1PE11.4)
9020 FORMAT (2X, I6, 2I7, I8, I9, 3X, 1PE11.4, 2X, 1PE11.4, 2X,
+ 1PE11.4, 2X, 1PE11.4, 2X, 1PE11.4)
9021 FORMAT (3(1X, I5), 1X, I5, 3X, I5, 1X, 5(1X, 1PE11.4),
+ 3(1X, 0PE11.4), 1(1X, 1PE11.4))
9022 FORMAT (3(1X, I5), 1X, I5, 3X, I5, 1X, 5(1X, 1PE11.4),
+ 3(1X, 0PE11.4), 2(1X, 1PE11.4))
C
C13-----CHECK RANGE AND ORDER FOR SEGMENTS AND REACHES.
IF ( jseg.LE.0 .OR. jseg.GT.NSS ) THEN
WRITE (IOUT, 9023)
CALL USTOP(' ')
END IF
IF ( jseg.NE.nseg ) THEN
nseg = nseg + 1
nreach = 0
IF ( jseg.NE.nseg ) THEN
WRITE (IOUT, 9024)
CALL USTOP(' ')
END IF
END IF
nreach = nreach + 1
IF ( ireach.NE.nreach ) THEN
WRITE (IOUT, 9025)
CALL USTOP(' ')
END IF
9023 FORMAT (' SEGMENT MUST BE GREATER THAN 0 AND LESS THAN NSS')
9024 FORMAT (' SEGMENTS MUST BE IN ORDER FROM 1 THROUGH NSS')
9025 FORMAT (' EACH SEGMENT MUST START WITH REACH 1, AND', /,
+ ' REACHES MUST BE NUMBERED CONSECUTIVELY')
ISTRM(1, ii) = krch
ISTRM(2, ii) = irch
ISTRM(3, ii) = jrch
ISTRM(4, ii) = jseg
ISTRM(5, ii) = ireach
SEG(1, ISTRM(4, ii)) = SEG(1, ISTRM(4, ii)) + STRM(1, ii)
C Number of reaches in segment added to ISEG
ISEG(4, jseg) = ireach
END DO
C
C14-----READ SEGMENT INFORMATION FOR FIRST STRESS PERIOD.
IF ( NSFRPAR.EQ.0 ) THEN
READ (In, *) ITMP, IRDFLG, IPTFLG
NP = 0
nlst = NSS
lb = 1
ichk = 1
CALL SGWF2SFR7RDSEG(nlst, lb, In, Iunitgwt, NSEGCK, NSS, ichk,
+ 1, Nsol)
END IF
C
C15-----COMPUTE UNSATURATED VARIABLE WHEN SPECIFIED BY SEGMENT.
IF ( IUZT.EQ.1 ) THEN
irch = 1
ksfropt = 0
DO nseg = 1, NSS
icalc = ISEG(1, nseg)
seglen = SEG(1, nseg)
sumlen = 0.0
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) THEN
IF ( ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
ksfropt = 1
thsslpe = (SEG(18, nseg)-SEG(22, nseg))/seglen
thislpe = (SEG(19, nseg)-SEG(23, nseg))/seglen
epsslpe = (SEG(20, nseg)-SEG(24, nseg))/seglen
IF ( ISFROPT.EQ.5 )
+ uhcslpe = (SEG(21, nseg)-SEG(25, nseg))/seglen
END IF
END IF
DO ii = 1, ISEG(4, nseg)
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) THEN
krck = ISTRM(1, irch)
irck = ISTRM(2, irch)
jrck = ISTRM(3, irch)
rchlen = STRM(1, irch)
dist = sumlen + (0.5*rchlen)
IF ( ksfropt.EQ.1 ) THEN
THTS(irch) = SEG(18, nseg) - (thsslpe*dist)
THTI(irch) = SEG(19, nseg) - (thislpe*dist)
EPS(irch) = SEG(20, nseg) - (epsslpe*dist)
IF ( ISFROPT.EQ.5 ) UHC(irch) = SEG(21, nseg)
+ - (uhcslpe*dist)
END IF
C
C16-----CALCULATE RESIDUAL WATER CONTENT FROM SATURATED WATER CONTENT
C AND SPECIFIC YIELD WHEN UNSATURATED FLOW IS ACTIVE.
! RGN 5/8/09 Fixed calculation of THTR to include HUF
IF ( ITRSS.EQ.1 ) THEN
IF ( ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
IF ( Iunitlpf.GT.0 ) THEN
THTR(irch) = THTS(irch) - SC2LPF(jrck, irck, krck)
+ /(DELR(jrck)*DELC(irck))
ELSE IF ( Iunitbcf.GT.0 ) THEN
IF( LAYCON(krck).EQ.1 ) THEN
THTR(irch) = THTS(irch) - SC1(jrck, irck, krck)
+ /(DELR(jrck)*DELC(irck))
ELSE
THTR(irch) = THTS(irch) - SC2(jrck, irck, krck)
+ /(DELR(jrck)*DELC(irck))
END IF
ELSE IF( Iunithuf.GT.0 ) THEN
THTR(irch) = THTS(irch) - SC2HUF(jrck, irck)
END IF
END IF
ELSEIF ( ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
THTR(irch) = 0.0
END IF
C
C17-----CHECK THAT RESIDUAL WATER CONTENT IS LESS THAN
C SATURATED WATER CONTENT.
IF ( IUZT.EQ.1 ) THEN
IF ( THTR(irch).GE.THTS(irch) ) THEN
WRITE (IOUT, 9026)
CALL USTOP(' ')
END IF
IF ( THTI(irch).GT.THTS(irch) ) THEN
WRITE (IOUT, 9027)
CALL USTOP(' ')
END IF
Cdep Added check that THTI is greater than THTR.
IF ( THTI(irch).LT.THTR(irch) ) THEN
WRITE (IOUT, 9028)ISTRM(4,irch), ISTRM(5,irch),
+ THTR(irch)
THTI(irch) = THTR(irch)
END IF
END IF
sumlen = sumlen + rchlen
END IF
irch = irch + 1
END DO
END DO
END IF
9026 FORMAT (' RESIDUAL WATER CONTENT IS EQUAL OR GREATER THAN ',
+ 'SATURATED WATER CONTENT. CHECK INPUT DATA FOR SPECIFIC',
+ ' YIELD AND SATURATED WATER CONTENT')
9027 FORMAT (' INITIAL WATER CONTENT IS GREATER THAN SATURATED ',
+ 'WATER CONTENT. CHECK INPUT DATA')
9028 FORMAT (' INITIAL WATER CONTENT IS LESS THAN RESIDUAL ',
+ 'WATER CONTENT FOR STREAM SEGMENT: ',I5,' REACH: ',I5,
+ ' INITIAL WATER CONTENT RESET TO RESIDUAL OF ',E12.5)
C
C18-----CHECK IF STREAM REACH IS IN ACTIVE CELL.
kkptflg = 0
DO ichk = 1, NSTRM
krck = ISTRM(1, ichk)
irck = ISTRM(2, ichk)
jrck = ISTRM(3, ichk)
jsegck = ISTRM(4, ichk)
ireachck = ISTRM(5, ichk)
IF ( IBOUND(jrck, irck, krck).EQ.0 ) THEN
kkptflg = kkptflg + 1
IF ( kkptflg.EQ.1 ) WRITE (IOUT, 9029) jsegck, ireachck,
+ IBOUND(jrck, irck, krck), krck,
+ irck, jrck
ELSE IF ( IBOUND(jrck, irck, krck).LT.0 ) THEN
WRITE (IOUT, 9030) jsegck, ireachck, IBOUND(jrck, irck, krck),
+ krck, irck, jrck
END IF
END DO
IF ( kkptflg.EQ.1 ) THEN
WRITE (IOUT, 9031)
ELSE IF ( kkptflg.GT.1 ) THEN
WRITE (IOUT, 9032) kkptflg
END IF
C
9029 FORMAT (/, ' *** WARNING *** FIRST OCCURRENCE WHERE A ',
+ 'STREAM REACH IS ASSIGNED TO AN INACTIVE CELL IS SEGMENT',
+ I5, ' REACH NO.', I5, /, ' IBOUND ARRAY VALUE IS', I5,
+ ' AT LAYER', I5, '; ROW', I5, '; COLUMN', I5, '.')
9030 FORMAT (/, ' *** WARNING *** STREAM SEGMENT', I5, ' REACH NO.',
+ I5, ' IS CONNECTED TO A CONSTANT HEAD CELL.'/,
+ ' IBOUND ARRAY VALUE IS', I5, ' AT ', 'LAYER', I5,
+ '; ROW', I5, '; COLUMN', I5, '.', /,
+ ' NO STREAM LEAKAGE WILL BE ALLOWED-- SUGGEST ',
+ 'REMOVING STREAM REACH FROM CELL OR CHANGE CELL ',
+ 'TO VARIABLE HEAD.', /)
9031 FORMAT (/, ' *** WARNING *** ONLY 1 STREAM REACH WAS ',
+ 'ASSIGNED TO A CELL WHERE THE IBOUND ARRAY WAS ZERO.', /,
+ ' PROGRAM SEARCHES FOR UPPERMOST ACTIVE CELL IN VERTICAL',
+ ' COLUMN,IF ALL CELLS ARE INACTIVE, STREAM LEAKAGE WILL',
+ ' NOT BE ALLOWED. ', /)
9032 FORMAT (/, ' *** WARNING *** A TOTAL OF', I6, 'STREAM REACHES ',
+ 'WERE ASSIGNED TO CELLS WHERE THE IBOUND ARRAY WAS ZERO.',
+ /, ' PROGRAM SEARCHES FOR UPPERMOST ACTIVE CELL IN',
+ ' VERTICAL COLUMN FOR ALL OCCURRENCES.', /,
+ ' IF ALL CELLS IN A VERTICAL COLUMN ARE INACTIVE,',
+ ' STREAM LEAKAGE WILL NOT BE ALLOWED FOR ASSOCIATED',
+ ' STREAM REACH. ', /)
C
C19-----READ PARAMETER DEFINITIONS.
IF ( NSFRPAR.GT.0 ) THEN
lstsum = NSS + 1
DO ii = 1, NSFRPAR
lstbeg = lstsum
CALL UPARLSTRP(lstsum, nsegdim, In, IOUT, ip, 'SFR', 'SFR',
+ iterp, numinst)
nlst = lstsum - lstbeg
IF ( numinst.GT.1 ) nlst = nlst/numinst
C
C20-----ASSIGN STARTING INDEX FOR READING INSTANCES.
IF ( numinst.EQ.0 ) THEN
ib = 0
ELSE
ib = 1
END IF
C
C21-----READ LIST(S) OF CELLS, PRECEDED BY INSTANCE NAME IF NUMINST>0.
Cdep Revised to change ib loop counter
lb = lstbeg
DO i = ib, numinst
IF ( i.GT.0 ) CALL UINSRP(i, In, IOUT, ip, iterp)
ichk = 0
CALL SGWF2SFR7RDSEG(nlst, lb, In, Iunitgwt, idum, 1, ichk,
+ 1, Nsol)
CALL SGWF2SFR7PRSEG(nlst, lb, Iunitgwt, 1, Nsol, Iouts)
lb = lb + nlst
END DO
END DO
END IF
C
WRITE (IOUT, 9033)
9033 FORMAT (//)
C
C22-----INITIALIZE VARIABLES AND LISTS FOR UNSATURATED FLOW BENEATH STREAM.
C NWAVS INITIALLY SET TO 1.
ALLOCATE (FOLDFLBT(mstrmar))
Nfoldflbt = mstrmar
FOLDFLBT = 0.0D0
ALLOCATE (UZFLWT(ISUZN,NUZST), UZSTOR(ISUZN,NUZST))
UZFLWT = 0.0D0
UZSTOR = 0.0D0
ALLOCATE (UZWDTH(ISUZN,NUZST), UZSEEP(ISUZN,NUZST))
UZWDTH = 0.0D0
UZSEEP = 0.0D0
ALLOCATE (DELSTOR(ISUZN,NUZST), UZOLSFLX(ISUZN,NUZST))
DELSTOR = 0.0D0
UZOLSFLX = 0.0D0
ALLOCATE (NWAVST(ISUZN,NUZST))
NWAVST = 1
ALLOCATE (UZDPIT(NSTOTRL,NUZST), UZDPST(NSTOTRL,NUZST))
UZDPIT = 0.0D0
UZDPST = 0.0D0
ALLOCATE (UZTHIT(NSTOTRL,NUZST), UZTHST(NSTOTRL,NUZST))
UZTHIT = 0.0D0
UZTHST = 0.0D0
ALLOCATE (UZSPIT(NSTOTRL,NUZST), UZSPST(NSTOTRL,NUZST))
UZSPIT = 0.0D0
UZSPST = 0.0D0
ALLOCATE (UZFLIT(NSTOTRL,NUZST), UZFLST(NSTOTRL,NUZST))
UZFLIT = 0.0D0
UZFLST = 0.0D0
ALLOCATE (LTRLIT(NSTOTRL,NUZST), LTRLST(NSTOTRL,NUZST))
LTRLIT = 0
LTRLST = 0
ALLOCATE (ITRLIT(NSTOTRL,NUZST), ITRLST(NSTOTRL,NUZST))
ITRLIT = 0
ITRLST = 0
ALLOCATE (ITRLSTH(NSTOTRL))
ITRLSTH = 0
ALLOCATE (WETPER(ISUZN,NUZST))
WETPER = 0.0D0
ALLOCATE (AVDPT(NUMAVE,NUZST), AVWAT(NUMAVE,NUZST))
AVDPT = 0.0
AVWAT = 0.0
ALLOCATE (WAT1(NUMAVE,NUZST))
WAT1 = 0.0
C
C22B-----INITIALIZE VARIABLES FOR STREAM DEPTH, LEAKAGE, AND
C PREVIOUS HEAD BENEATH STREAM.
ALLOCATE (SUMLEAK(nstrmar))
SUMLEAK = 0.0D0
ALLOCATE (SUMRCH(nstrmar))
SUMRCH = 0.0D0
ALLOCATE (HLDSFR(nstrmar))
HLDSFR = 0.0D0
C ------------------------------------------------------------------
C
IF ( Iunitlpf.GT.0 .OR. Iunithuf.GT.0 ) THEN
IF ( ISFROPT.EQ.2.OR.ISFROPT.EQ.4 )
+ CALL SGWF2SFR7UHC(Iunitlpf, Iunithuf)
END IF
C
C23-----SAVE POINTERS FOR GRID AND RETURN.
CALL SGWF2SFR7PSV(Igrid)
RETURN
END SUBROUTINE GWF2SFR7AR
C
C-------SUBROUTINE SGWF2SFR7UHC
SUBROUTINE SGWF2SFR7UHC(Iunitlpf, Iunithuf)
C ******************************************************************
C SETS UNSATURATED VERTICAL HYDRAULIC CONDUCTIVITY TO VERTICAL
C HYDRAULIC CONDUCTIVITY IN THE LAYER-PROPERTY FLOW PACKAGE.
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NSTRM, ISTRM, UHC
USE GLOBAL, ONLY: IOUT, IBOUND
USE GWFLPFMODULE, ONLY: LAYVKA, LAYTYP, VKA, HK
USE GWFHUFMODULE, ONLY: HGUVANI, NHUF, HKHUF=>HK, VKAH
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
INTEGER Iunitlpf, Iunithuf
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER ichk, irck, jrck, krck
C ------------------------------------------------------------------
C
C1------SET UHC EQUAL TO VKA IF STREAM IS IN ACTIVE CELL.
DO ichk = 1, NSTRM
krck = ISTRM(1, ichk)
irck = ISTRM(2, ichk)
jrck = ISTRM(3, ichk)
IF ( Iunitlpf.GT.0 ) THEN
IF ( IBOUND(jrck, irck, krck).GT.0 ) THEN
IF ( LAYVKA(krck).EQ.0 ) THEN
UHC(ichk) = VKA(jrck, irck, krck)
ELSE
UHC(ichk) = VKA(jrck, irck, krck)*
+ HK(jrck, irck, krck)
END IF
IF ( LAYTYP(krck).LE.0 ) THEN
WRITE (IOUT, *) 'PROGRAM TERMINATED-LAYTYP MUST BE GREATER',
+ ' THAN ZERO WHEN ISFROPT IS 2 OR 4.'
CALL USTOP(' ')
END IF
END IF
ELSE
IF ( IBOUND(jrck, irck, krck).GT.0 ) THEN
IF ( HGUVANI(NHUF).LE.0.0 ) THEN
UHC(ichk) = VKAH(jrck, irck, krck)
ELSE
UHC(ichk) = HGUVANI(NHUF)*
+ HKHUF(jrck, irck, krck)
END IF
END IF
END IF
END DO
C
C2------RETURN.
RETURN
END SUBROUTINE SGWF2SFR7UHC
C
C-------SUBROUTINE GWF2SFR7RP
SUBROUTINE GWF2SFR7RP(In, Iunitgwt, Iunitlak, Kkper, Nsol, Iouts,
+ Igrid)
C ******************************************************************
C READ STREAM DATA FOR STRESS PERIOD
C VERSION 7.1.01: February 15, 2009
C Compute three new tables for lake outflow
C ******************************************************************
USE GWFSFRMODULE
USE GLOBAL, ONLY: IOUT, ISSFLG, IBOUND, BOTM, HNEW, NLAY
USE PARAMMODULE, ONLY: MXPAR, PARTYP, IACTIVE, IPLOC
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Kkper, In, Iunitgwt, Iunitlak, Nsol, Iouts, Igrid
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION h, sbot
REAL avdpth, avhc, avthk, bottom, dist, dpslpe, dpth1, dpth2,
+ dpthlw, dndiff, eldn, elslpe, etsw, flw1, flw2, flwlw,
+ hcslpe, pptsw,rchlen, rough, roughbnk, roughch, runoff,
+ seglen, strlen, sumlen, thkslpe, top, wdslpe, wdth1, wdth2,
+ wdthlw, width, updiff, zero
INTEGER i, ic, icalc, ichk, icp, iflginit, ii, ik, il, ilay, ip,
+ ipt, ir, irch, irp, isoptflg, iss, istep, istsg, iwvcnt,
+ jj, jk, k5, k6, k7, kk, ksfropt, kss, ktot, l, lstbeg,
+ nseg, nstrpts
C ------------------------------------------------------------------
C
C-------SET POINTERS FOR CURRENT GRID.
CALL SGWF2SFR7PNT(Igrid)
C
C1------READ ITMP FLAG TO REUSE NON-PARAMETER DATA, 2 PRINTING FLAGS,
C AND NUMBER OF PARAMETERS BEING USED IN CURRENT STRESS PERIOD.
iss = ISSFLG(Kkper)
zero = 1.0E-7
Cdep added NSFRPAR to IF statement
IF ( Kkper.GT.1 ) THEN
IF ( NSFRPAR.EQ.0 ) THEN
READ (In, *) ITMP, IRDFLG, IPTFLG
NP = 0
ELSE
READ (In, *) ITMP, IRDFLG, IPTFLG, NP
END IF
ELSE IF ( NSFRPAR.GT.0 ) THEN
READ (In, *) ITMP, IRDFLG, IPTFLG, NP
END IF
C
C2------CHECK FOR TOO MANY SEGMENTS.
IF ( ITMP.GT.NSS ) THEN
WRITE (IOUT, 9001)
CALL USTOP(' ')
END IF
C
C3------REUSE NON-PARAMETER DATA FROM LAST STRESS PERIOD IF ITMP<0.
IF ( ITMP.GE.0 ) THEN
C
C4------NOT REUSING DATA -- INITIALIZE NSEGCK LIST TO ZERO FOR ALL
C SEGMENTS. Moved NSEGCK below ELSE IF 6/9/2005 dep
call sts2data(in) ! STS
IF ( Kkper.GT.1 ) THEN
DO kss = 1, NSS
NSEGCK(kss) = 0
END DO
END IF
ELSE IF ( Kkper.EQ.1 ) THEN
call sts2nodata(in) ! STS
WRITE (IOUT, 9002)
CALL USTOP(' ')
ELSE IF ( NSFRPAR.EQ.0 .AND. IUZT.EQ.0 ) THEN
call sts2nodata(in) ! STS
WRITE (IOUT, 9003)
RETURN
ELSE IF ( NSFRPAR.NE.0 ) THEN
C
C5------INITIALIZE NSEGCK TO 0 FOR SEGMENTS THAT ARE DEFINED BY
C CURRENTLY USED PARAMETERS.
call sts2nodata(in) ! STS
WRITE (IOUT, 9003)
DO ip = 1, MXPAR
IF ( PARTYP(ip).EQ.'SFR' .AND. IACTIVE(ip).GT.0 ) THEN
DO ic = IPLOC(1, ip), IPLOC(2, ip)
NSEGCK(ISEG(3, ic)) = 0
END DO
END IF
END DO
END IF
9001 FORMAT (/, ' CANNOT SPECIFY MORE THAN NSS STREAM SEGMENTS')
9002 FORMAT (//, ' *** STREAM SEGMENTS MUST BE DEFINED FOR ',
+ 'FIRST STRESS PERIOD; CODE STOPPING ***')
9003 FORMAT (/, ' REUSING STREAM SEGMENT DATA FROM LAST STRESS PERIOD')
C
C6------READ NON-PARAMETER STREAM SEGMENT DATA.
IF ( ITMP.GT.0 ) THEN
lstbeg = 1
ichk = 1
IF ( ISFROPT.GT.0 ) THEN
IF ( Kkper.GT.1 ) CALL SGWF2SFR7RDSEG(ITMP, lstbeg, In,
+ Iunitgwt, NSEGCK, NSS,
+ ichk, Kkper, Nsol)
Crgn 10/16/06 fixed logic for calls to RDSEG
ELSEIF( NSFRPAR.EQ.0 ) THEN
IF ( Kkper.GT.1 )CALL SGWF2SFR7RDSEG(ITMP, lstbeg, In,
+ Iunitgwt, NSEGCK, NSS,
+ ichk, Kkper, Nsol)
ELSEIF( NSFRPAR.GT.0 ) THEN
CALL SGWF2SFR7RDSEG(ITMP, lstbeg, In,
+ Iunitgwt, NSEGCK, NSS,
+ ichk, Kkper, Nsol)
END IF
END IF
C
C7------DEACTIVATE ANY PREVIOUSLY USED STREAM PARAMETERS, AND
C ACTIVATE PARAMETERS BEING USED IN CURRENT STRESS PERIOD.
IF ( NSFRPAR.NE.0 ) THEN
CALL PRESET('SFR')
DO jj = 1, NP
CALL SGWF2SFR7PARMOV(In, Iunitgwt, Nsol)
END DO
END IF
C
C8------CHECK FOR ERRORS IN SEGMENT DATA.
IF ( ITMP.GT.0 .OR. NSFRPAR.NE.0 ) THEN
DO nseg = 1, NSS
IF ( ISFROPT.EQ.0 ) THEN
IF ( NSEGCK(nseg).LE.0 .AND. Kkper.EQ.1 ) THEN
WRITE (IOUT, 9004) nseg
ELSE IF ( NSEGCK(nseg).GT.1 ) THEN
WRITE (IOUT, 9005) nseg, NSEGCK(nseg)
CALL USTOP(' ')
END IF
END IF
C
C9------READ DATA ACCORDING TO VARIABLE ISFROPT.
isoptflg = 0
IF ( ISFROPT.EQ.1 .OR. ISFROPT.EQ.2 .OR. ISFROPT.EQ.3 )
+ isoptflg = 1
IF ( isoptflg.EQ.0 .AND. SEG(8,nseg).LE.SEG(13,nseg) ) THEN
WRITE (IOUT, 9006) nseg
IF ( ISEG(1, nseg).EQ.1 .OR. ISEG(1, nseg).EQ.2 ) THEN
WRITE (IOUT, 9007) nseg, ISEG(1, nseg)
CALL USTOP(' ')
END IF
END IF
IF ( IDIVAR(2, nseg).GT.0 ) THEN
WRITE (IOUT, 9008) nseg
IDIVAR(2, nseg) = 0
ELSE IF ( IDIVAR(2, nseg).LT.-3 ) THEN
WRITE (IOUT, 9009) nseg
IDIVAR(2, nseg) = 0
ELSE IF ( IDIVAR(2, nseg).EQ.-2 ) THEN
IF ( SEG(2, nseg).LT.0.0 .OR. SEG(2, nseg).GT.1.0 ) THEN
WRITE (IOUT, 9010) nseg
SEG(2, nseg) = 0.0
END IF
END IF
END DO
9004 FORMAT (/, 5X, '*** WARNING *** INPUT DATA FOR SEGMENT', I7,
+ ' WERE NOT DEFINED')
9005 FORMAT (/, 5X, '*** ERROR *** DATA FOR SEGMENT', I6,
+ ' WERE DEFINED', I3, ' TIMES (INSTEAD OF ONCE)')
9006 FORMAT (/, 5X, '*** WARNING *** UPSTREAM ELEVATION IS ',
+ 'EQUAL TO OR LOWER THAN DOWNSTREAM ELEVATION FOR ',
+ 'SEGMENT No. ', I6)
9007 FORMAT (/, 5X, '*** ERROR *** ',
+ 'SLOPE IS ZERO OR NEGATIVE FOR SEGMENT No.', I5,
+ ' SLOPE MUST BE POSITIVE WHEN ICALC IS', I3)
9008 FORMAT (/, 5X, '*** WARNING *** IPRIOR > 0 FOR NSEG =', I7, /,
+ 10X, 'THIS OPTION NOT YET AVAILABLE; CODE WILL ',
+ 'ASSUME IPRIOR = 0', /)
9009 FORMAT (/, 5X, '*** WARNING *** IPRIOR < -3 FOR NSEG =', I7, /,
+ 10X, 'THIS VALUE IS OUT OF RANGE; CODE WILL ',
+ 'ASSUME IPRIOR = 0', /)
9010 FORMAT (/, 5X, '*** WARNING *** IPRIOR = -2 FOR NSEG =', I7,
+ ' & FLOW VALUE IS OUT OF RANGE (.0 - 1.);', /, 10X,
+ 'ASSUME NO DIVERSION OF FLOW', /)
C
C10-----PLACE STREAM SEGMENT IDENTITY NUMBERS IN ISEG ARRAY.
C 5 ASSIGNED TO SEGMENTS NOT RECEIVING TRIBUTARY FLOW.
C 6 ASSINGED TO SEGMENTS THAT DIVERT FLOW.
C 7 ASSIGNED TO SEGMENTS RECEIVING TRIBUTARY FLOW.
k5 = 0
k6 = 0
k7 = 0
DO nseg = 1, NSS
C
C11-----IDENTIFY SEGMENTS THAT DIVERT FLOW.
IF ( IDIVAR(1, nseg).NE.0 ) THEN
ISEG(3, nseg) = 6
k6 = k6 + 1
C
C12-----IDENTIFY SEGMENTS THAT DO NOT DIVERT FLOW.
ELSE
jj = 0
C
C13-----IDENTIFY SEGMENTS THAT RECEIVE TRIBUTARY FLOW.
DO ii = 1, NSS
IF ( IOTSG(ii).EQ.nseg ) jj = 1
END DO
C
C14-----IDENTIFY SEGMENTS THAT DO NOT RECEIVE TRIBUTARY FLOW.
IF ( jj.EQ.0 ) THEN
ISEG(3, nseg) = 5
k5 = k5 + 1
ELSE
ISEG(3, nseg) = 7
k7 = k7 + 1
IF ( jj.NE.1 ) WRITE (IOUT, 9011) nseg, jj
END IF
END IF
END DO
C
C15-----TALLY DIFFERENT STREAM SEGMENT TYPES.
ktot = k5 + k6 + k7
WRITE (IOUT, 9012) k5, k6, k7
C
C16-----PRINT WARNING IF TALLIED SEGMENTS LESS THAN NSS.
IF ( ktot.NE.NSS ) THEN
WRITE (IOUT, 9013) ktot, NSS
CALL USTOP(' ')
END IF
9011 FORMAT (//, 5X, '*** WARNING *** ERROR WHILE ',
+ 'CLASSIFYING SEGMENTS: NSEG =', I6, 4X, 'JJ =', I6,//)
9012 FORMAT (///1X, 'CLASSIFICATION & COUNT OF STREAM SEGMENTS ',
+ 'BASED ON SOURCE OF INFLOW:', //, 16X,
+ 'HEADWATER DIVERSION RECEIVES TRIBUTARY FLOW', /
+ 16X, '--------- --------- ',
+ ' -----------------------', /, 16X, I6, I15, I16, /)
9013 FORMAT (/, 5X, '*** WARNING *** INTERNAL ERROR SUMMING ',
+ 'TYPES OF STREAM SEGMENTS: NSEG =', I6, 5X, 'JJ =',
+ I6//)
C
C17-----PRINT INPUT DATA IF IRDFLG IS ZERO.
C SKIP IF INPUT READ BY REACHES (ISFROPT = 1, 3, OR 5)
IF ( IRDFLG.LE.0 ) CALL SGWF2SFR7PRSEG(NSS, 1, Iunitgwt, Kkper,
+ Nsol, Iouts)
C
C18-----COMPUTE STREAM REACH VARIABLES.
irch = 1
ksfropt = 0
DO nseg = 1, NSS
icalc = ISEG(1, nseg)
seglen = SEG(1, nseg)
runoff = SEG(3, nseg)
etsw = SEG(4, nseg)
pptsw = SEG(5, nseg)
sumlen = 0.0
C
C19-----COMPUTE VARIABLES NEEDED FOR STREAM LEAKAGE.
IF ( icalc.EQ.0 .OR. icalc.EQ.1 ) THEN
wdslpe = (SEG(9, nseg)-SEG(14, nseg))/seglen
IF ( icalc.EQ.0 ) dpslpe = (SEG(10, nseg)-SEG(15, nseg))
+ /seglen
END IF
IF ( ISFROPT.EQ.0 .OR. ISFROPT.EQ.4 .OR. ISFROPT.EQ.5 ) THEN
ksfropt = 1
elslpe = (SEG(8, nseg)-SEG(13, nseg))/seglen
hcslpe = (SEG(6, nseg)-SEG(11, nseg))/seglen
thkslpe = (SEG(7, nseg)-SEG(12, nseg))/seglen
END IF
DO ii = 1, ISEG(4, nseg)
rchlen = STRM(1, irch)
dist = sumlen + (0.5*rchlen)
STRM(12, irch) = runoff*(rchlen/seglen)
IF ( ksfropt.EQ.1 ) THEN
avhc = SEG(6, nseg) - (hcslpe*dist)
avthk = SEG(7, nseg) - (thkslpe*dist)
STRM(2, irch) = elslpe
STRM(3, irch) = SEG(8, nseg) - (elslpe*dist)
STRM(4, irch) = STRM(3, irch) - avthk
STRM(6, irch) = avhc
STRM(8, irch) = avthk
C20-----COMPUTE STREAMBED ELEVATION AND STREAM WIDTH FOR BEGINNING
C OF EACH STREAM SEGMENT FOR COMPUTATION OF LAKE OUTFLOW.
cdep 4/26/2006
ELSE
IF ( ii.EQ.1) THEN
SEG(8,nseg) = STRM(3,irch) + ( 0.5 * STRM(1,irch)
+ * STRM(2,irch) )
END IF
END IF
!dep 4/28/2008 Added check and warning for streambed thickness
IF (STRM(8, irch).LT.CLOSEZERO)THEN
WRITE (IOUT, 9030) nseg, irch, STRM(8, irch)
STRM(8, irch) = 1.0
END IF
!dep 4/28/2008 end of change
IF ( icalc.EQ.0 ) THEN
avdpth = SEG(10, nseg) - (dpslpe*dist)
STRM(5, irch) = SEG(9, nseg) - (wdslpe*dist)
STRM(7, irch) = avdpth
STRM(13, irch) = etsw*rchlen*STRM(5, irch)
STRM(14, irch) = pptsw*rchlen*STRM(5, irch)
STRM(15, irch) = avdpth + STRM(3, irch)
IF ( ksfropt.EQ.1 ) STRM(16, irch)
+ = (avhc*STRM(5, irch)*rchlen)/avthk
ELSE IF ( icalc.EQ.1 ) THEN
STRM(5, irch) = SEG(9, nseg) - (wdslpe*dist)
STRM(7, irch) = 1.0
STRM(13, irch) = etsw*rchlen*STRM(5, irch)
STRM(14, irch) = pptsw*rchlen*STRM(5, irch)
STRM(15, irch) = STRM(3, irch)
IF ( ksfropt.EQ.1 ) STRM(16, irch)
+ = (avhc*STRM(5, irch)*rchlen)/avthk
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
STRM(5, irch) = 1.0
STRM(7, irch) = 1.0
STRM(13, irch) = etsw*rchlen
STRM(14, irch) = pptsw*rchlen
STRM(15, irch) = STRM(3, irch)
IF ( ksfropt.EQ.1 )
+ STRM(16, irch) = STRM(5, irch)*STRM(1, irch)
+ *STRM(6, irch)/STRM(8, irch)
C
C21-----STOP IF ICALC LESS THAN 0 AND GREATER THAN 4.
ELSE
STOP 'icalc problem, < 0 or > 4'
END IF
sumlen = sumlen + rchlen
irch = irch + 1
END DO
END DO
C
C22-----CHECK VALUES IN STREAM CROSS SECTION LIST (XSEC).
DO nseg = 1, NSS
icalc = ISEG(1, nseg)
IF ( icalc.EQ.2 ) THEN
IF ( ABS(XSEC(1,nseg)).GT.zero ) THEN
WRITE (IOUT, 9014) nseg
CALL USTOP(' ')
END IF
DO jj = 1, 8
IF ( XSEC(jj, nseg).LT.0.0 ) THEN
WRITE (IOUT, 9015) nseg, jj, XSEC(jj, nseg)
CALL USTOP(' ')
END IF
kk = jj + 8
IF ( XSEC(kk, nseg).LT.0.0 ) THEN
WRITE (IOUT, 9016) nseg, kk, XSEC(kk, nseg)
CALL USTOP(' ')
END IF
END DO
END IF
END DO
9030 FORMAT (/, ' *** WARNING *** STREAMBED THICKNESS',
+ 'FOR SEGMENT ',I10,' REACH ',I10,
+ ' IS ', E10.4,' WHICH IS ZERO OR LESS. '/,
+ ' VALUE MUST BE GREATER THAN ZERO-- IT HAS BEEN ',
+ 'RESET TO 1.0')
9014 FORMAT (1X, /, ' *** ERROR *** EIGHT POINT CROSS ',
+ 'SECTION FOR STREAM SEGMENT', I7,
+ ' DOES NOT BEGIN WITH ZERO FOR FIRST VALUE --',
+ 'PROGRAM STOPPING')
9015 FORMAT (1X, /, ' *** ERROR *** STREAM SEGMENT', I7,
+ ' HAS A NEGATIVE X DISTANCE FOR POINT', I6,
+ ' INPUT VALUE IS', E11.3, /,
+ ' ALL VALUES MUST BE POSITIVE WITH ',
+ 'FIRST X VALUE STARTING AT EXTREME LEFT ',
+ 'EDGE OF SECTION LOOKING DOWNSTREAM PROGRAM STOPPING')
9016 FORMAT (1X, /, ' *** ERROR *** STREAM SEGMENT', I7,
+ ' HAS A NEGATIVE Z DISTANCE FOR POINT', I6,
+ ' INPUT VALUE IS', E11.3, /,
+ ' ALL VALUES MUST BE POSITIVE RELATIVE ',
+ 'TO STREAMBED ELEVATION ')
C
C23-----CHECK ROUGHNESS COEFFICIENTS WHEN ICALC = 1 OR 2.
DO nseg = 1, NSS
icalc = ISEG(1, nseg)
IF ( icalc.EQ.1 ) THEN
rough = SEG(16, nseg)
IF ( rough.LE.0.0 ) THEN
WRITE (IOUT, 9017) rough
CALL USTOP(' ')
END IF
ELSE IF ( icalc.EQ.2 ) THEN
roughch = SEG(16, nseg)
roughbnk = SEG(17, nseg)
IF ( roughch.LE.0.0 ) THEN
WRITE (IOUT, 9018) roughch
CALL USTOP(' ')
ELSE IF ( roughbnk.LE.0.0 ) THEN
WRITE (IOUT, 9019) roughbnk
CALL USTOP(' ')
END IF
END IF
END DO
9017 FORMAT ('*** ERROR *** ROUGHNESS COEFFICIENT WHEN ',
+ 'ICALC = 1 IS LESS THAN OR EQUAL TO ZERO', //,
+ ' VALUE IS', 1PE11.3, //, ' PROGRAM STOPPING')
9018 FORMAT ('*** ERROR *** ROUGHNESS COEFFICIENT FOR ',
+ 'CHANNEL WHEN ICALC =2 IS LESS THAN OR EQUAL TO ZERO',//
+ ' VALUE IS', 1PE11.3, //, ' PROGRAM STOPPING')
9019 FORMAT ('*** ERROR *** ROUGHNESS COEFFICIENT FOR BANK ',
+ 'WHEN ICALC =2 IS LESS THAN OR EQUAL TO ZERO', //,
+ ' VALUE IS', 1PE11.3, //, ' PROGRAM STOPPING')
C
C24-----CHECK VALUES IN TABLE OF FLOW VERSUS DEPTH AND WIDTH
C WHEN ICALC = 4.
DO nseg = 1, NSS
icalc = ISEG(1, nseg)
IF ( icalc.EQ.4 ) nstrpts = ISEG(2, nseg)
IF ( icalc.EQ.4 ) THEN
flwlw = QSTAGE(1, nseg)
IF ( flwlw.LE.0.0 ) THEN
WRITE (IOUT, 9020) nseg
QSTAGE(1, nseg) = 0.1
END IF
dpthlw = QSTAGE(1+nstrpts, nseg)
IF ( dpthlw.LE.0.0 ) THEN
WRITE (IOUT, 9021) nseg
QSTAGE(1+nstrpts, nseg) = 0.01
END IF
wdthlw = QSTAGE(1+2*nstrpts, nseg)
IF ( wdthlw.LE.0.0 ) THEN
WRITE (IOUT, 9022) nseg
QSTAGE(1+2*nstrpts, nseg) = 1.0
END IF
DO ipt = 2, nstrpts
flw1 = QSTAGE(ipt-1, nseg)
flw2 = QSTAGE(ipt, nseg)
dpth1 = QSTAGE((ipt-1)+nstrpts, nseg)
dpth2 = QSTAGE(ipt+nstrpts, nseg)
wdth1 = QSTAGE((ipt-1)+(2*nstrpts), nseg)
wdth2 = QSTAGE(ipt+(2*nstrpts), nseg)
IF ( flw2.LE.flw1 ) THEN
WRITE (IOUT, 9023) nseg, flw2, ipt
CALL USTOP(' ')
END IF
IF ( dpth2.LE.dpth1 ) THEN
WRITE (IOUT, 9024) nseg, dpth2, ipt
CALL USTOP(' ')
END IF
IF ( wdth2.LT.wdth1 ) WRITE (IOUT, 9025) nseg, wdth2, ipt
END DO
END IF
END DO
C
WRITE (IOUT, 9026)
END IF
9020 FORMAT (/, ' *** WARNING *** FIRST FLOW VALUE IN ',
+ 'TABLE OF FLOW VERSUS DEPTH AND WIDTH IS ',
+ 'LESS THAN OR EQUAL TO ZERO FOR SEGMENT NUMBER', I7, /,
+ ' VALUE SHOULD BE GREATER THAN ZERO-- IT HAS BEEN RESET ',
+ 'TO 0.1 BUT MAY CAUSE INSTABILITY')
9021 FORMAT (/, ' *** WARNING *** FIRST DEPTH VALUE IN TABLE ',
+ 'OF FLOW VERSUS DEPTH AND WIDTH IS LESS THAN ',
+ 'OR EQUAL TO ZERO FOR SEGMENT NUMBER', I7, /,
+ ' VALUE SHOULD BE GREATER THAN ZERO-- ',
+ 'IT HAS BEEN RESET TO 0.01 BUT MAY CAUSE INSTABILITY')
9022 FORMAT (/, ' *** WARNING *** FIRST WIDTH VALUE IN TABLE OF ',
+ 'FLOW VERSUS DEPTH AND WIDTH IS LESS THAN OR EQUAL',
+ ' TO ZERO FOR SEGMENT NUMBER', I7, /,
+ ' VALUE SHOULD BE GREATER THAN ZERO-- IT HAS BEEN ',
+ 'RESET TO 1.0 BUT MAY CAUSE INSTABILITY')
9023 FORMAT (/, ' *** ERROR *** SEGMENT NUMBER', I7,
+ 'HAS SPECIFIED FLOW VALUE OF', 1PE11.2, ' IN LOCATION',
+ I6, ' THAT IS LESS THAN OR EQUAL TO PRECEDING VALUE', /,
+ ' FLOW VALUES MUST BE GREATER THAN PRECEDING VALUE',
+ ' IN TABLE-- PROGRAM STOPPING')
9024 FORMAT (/, ' *** ERROR *** SEGMENT NUMBER', I7,
+ 'HAS SPECIFIED DEPTH VALUE OF', 1PE11.2, ' IN LOCATION',
+ I6, ' THAT IS LESS THAN OR EQUAL TO PRECEDING VALUE', /,
+ ' DEPTH VALUES MUST BE GREATER THAN PRECEDING VALUE',
+ ' IN TABLE-- PROGRAM STOPPING')
9025 FORMAT (/, ' *** WARNING *** SEGMENT NUMBER', I7,
+ ' HAS SPECIFIED WIDTH VALUE OF', 1PE11.2, ' IN LOCATION',
+ I6, ' THAT IS LESS THAN PRECEDING VALUE', /,
+ ' FOR MOST CHANNELS, WIDTH NORMALLY INCREASES WITH FLOW')
9026 FORMAT (//)
C
C25-----COMPUTE STREAMBED ELEVATIONS FOR TOP AND BOTTOM, AND STREAMBED
C SLOPE FROM LAND SURFACE ELEVATION WHEN SPECIFIED.
C MODIFIED BY WOLFGANG SCHMID FOR FARM PROCESS.
Crgn---3/19/07 separated if statement to avoid referencing zero elements in array.
IF( ABS(IRDFLG).EQ.2 ) THEN
DO irch = 2, NSTRM
IF( ISTRM(4, irch).GT.1 ) THEN
IF( IDIVAR(1,ISTRM(4, irch)-1).GT.0 ) THEN
icp = ISTRM(3, irch-1)
irp = ISTRM(2, irch-1)
IF( ISTRM(5, irch).EQ.1 ) SEG(13, ISTRM(4, irch)-1) =
+ BOTM(icp, irp, 0) - SEG(13, ISTRM(4, irch)-1 )
END IF
END IF
END DO
DO nseg = 1, NSS
IF( IDIVAR(1, nseg).GT.0 ) THEN
C
C26-----COMPUTE STREAMBED TOP ELEVATION FOR CANAL REACHES
C IN FARM PROCESS.
seglen = SEG(1, nseg)
sumlen = 0.0
DO irch = 1, NSTRM
IF( IDIVAR(1, ISTRM(4, irch)).EQ.IDIVAR(1, nseg) ) THEN
icalc = ISEG(1, nseg) !rsr, icalc needs a value
rchlen = STRM(1, irch)
dist = sumlen + (0.5 * rchlen)
sumlen = sumlen + rchlen
ic = ISTRM(3, irch)
ir = ISTRM(2, irch)
updiff = 0.0 !rsr, added to make sure updiff has a value
IF( ISTRM(5, irch).EQ.1 ) updiff = BOTM(ic, ir, 0) -
+ SEG(8, ISTRM(4, irch))
dndiff = SEG(13, ISTRM(4, irch))
STRM(3, irch) = BOTM(ic, ir, 0) - (updiff -
+ (((updiff - dndiff) / seglen) * dist))
avthk = SEG(7, nseg) - (((SEG(7, nseg) -
+ SEG(12, nseg)) / seglen) * dist)
STRM(4, irch) = STRM(3, irch) - avthk
IF ( icalc.EQ.0 ) THEN
STRM(15, irch) = avdpth + STRM(3, irch)
ELSE IF ( icalc.EQ.1 ) THEN
STRM(15, irch) = STRM(3, irch)
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
STRM(15, irch) = STRM(3, irch)
END IF
END IF
END DO
C
C27-----COMPUTE STREAMBED SLOPE FOR CANAL REACHES IN FARM PROCESS.
C NOTE THAT FIRST AND LAST REACH CAN NOT BE CANAL REACHES.
DO irch = 2, NSTRM-1
IF( IDIVAR(1, ISTRM(4, irch)).EQ.IDIVAR(1, nseg) ) THEN
STRM(2, irch) = (STRM(3, irch-1) - STRM(3,irch+1) )
+ / (0.5 * STRM(1, irch-1) +
+ STRM(1, irch) + 0.5 * STRM(1, irch+1))
IF( ISTRM(5, irch).EQ.1 ) THEN
STRM(2, irch) = (SEG(8, ISTRM(4, irch)) -
+ STRM(3, irch+1)) / (STRM(1, irch) +
+ 0.5 * STRM(1, irch+1))
END IF
IF( ISTRM(5, irch+1).LT.ISTRM(5, irch) ) THEN
ic = ISTRM(3, irch)
ir = ISTRM(2, irch)
dndiff = SEG(13,ISTRM(4, irch))
eldn = BOTM(ic,ir,0) - dndiff
STRM(2, irch) = (STRM(3, irch-1) - eldn) / (0.5 *
+ STRM(1, irch-1) + STRM(1, irch))
END IF
IF( STRM(2, irch).LT.zero ) THEN
IF( STRM(2, irch ).LT.zero ) STRM(2, irch) = 1.0E-06
WRITE(IOUT,9027) ISTRM(4,irch), ISTRM(5,irch),
+ STRM(2, irch)
9027 FORMAT(1X,'SLOPE FOR SEGMENT AND REACH ',2(1x,I5),
+ 'IS LESS THAN 1.0E-07: SETTING SLOPE TO '
+ '1.0E-06 ')
END IF
END IF
END DO
END IF
END DO
C
WRITE (IOUT, 9028)
9028 FORMAT (//)
END IF
C
C29-----SET FLAGS FOR STEADY STATE OR TRANSIENT SIMULATIONS.
iflginit = 0
IF ( Kkper.EQ.1 ) THEN
iflginit = 1
ELSE IF ( iss.EQ.0 .AND. ISSFLG(Kkper-1).NE.0 ) THEN
iflginit = 2
END IF
C
C30-----DETERMINE VARIABLES WHEN UNSATURATED FLOW IS ACTIVE.
DO l = 1, NSTRM
il = ISTRM(1, l)
ir = ISTRM(2, l)
ic = ISTRM(3, l)
h = HNEW(ic, ir, il)
HLDSFR(l) = h
IF ( IUZT.EQ.1 .AND. iflginit.GE.1 ) THEN
istsg = ISTRM(4, l)
icalc = ISEG(1, istsg)
sbot = STRM(4, l)
strlen = STRM(1, l)
width = STRM(5, l)
C
C31-----SKIP IF CELL IS OUTSIDE ACTIVE BOUNDARY OR IS NOT WATER TABLE.
Cdep
C31B-----SEARCH FOR UPPER MOST ACTIVE CELL IN STREAM REACH.
ilay = il !rsr, moved before IF to be sure ilay has a value
IF ( IBOUND(ic, ir, il).GT.0 ) THEN
!rsr ilay = il
TOPCELL: DO WHILE ( ilay.LE.NLAY )
IF ( HNEW(ic, ir, ilay).LE.BOTM(ic,ir,ilay) ) THEN
ilay = ilay + 1
ELSE
EXIT TOPCELL
END IF
END DO TOPCELL
END IF
IF ( ilay.LE.NLAY ) THEN
il = ilay
h = HNEW(ic, ir, il)
ELSE
h = DBLE(BOTM(ic,ir,NLAY))
END IF
IF ( IBOUND(ic, ir, il).LE.0 ) THEN
UZDPST(1, l) = 0.0D0
UZFLST(1, l) = 0.0D0
UZSPST(1, l) = 0.0D0
UZTHST(1, l) = THTR(l)
UZSTOR(1, l) = 0.0D0
UZOLSFLX(1, l) = 0.0D0
C
C32-----BREAK CHANNEL INTO ISUZN WIDTHS FOR UNSATURATED FLOW
C WHEN ICALC IS 2 AND UNSATURATED FLOW IS ACTIVE.
ELSE IF ( icalc.EQ.2 ) THEN
CALL CHANNELAREA(istsg, l)
istep = NSTOTRL/ISUZN
DO jk = 1, NSTOTRL
UZTHST(jk, l) = THTR(l)
END DO
C
C33-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN GROUND WATER HEAD
C IS LESS THAN BOTTOM OF STREAMBED.
IF ( sbot.GT.h ) THEN
iwvcnt = 1
DO i = 1, ISUZN
UZDPST(iwvcnt, l) = sbot - h
UZSPST(iwvcnt, l) = 0.0D0
NWAVST(i, l) = 1
C
C34-----INITIALIZE UNSATURATED ZONES ARRAYS FOR SECOND STRESS PERIOD
C WHEN FIRST STRESS PERIOD IS STEADY STATE.
IF ( iflginit.EQ.2 ) THEN
IF ( UZSEEP(i, l).GT.0.0 ) THEN
UZFLST(iwvcnt, l) = UZSEEP(i, l)
UZTHST(iwvcnt, l) = (((UZFLST(iwvcnt,l)/UHC(l))**(
+ 1.0D0/EPS(l)))*(THTS(l)-THTR(l))
+ ) + THTR(l)
top = UZTHST(iwvcnt, l) - THTR(l)
UZSTOR(i, l) = UZDPST(iwvcnt, l)*top
+ *WETPER(i, l)*strlen
UZOLSFLX(i, l) = UZSEEP(i, l)
ELSE
UZFLST(iwvcnt, l) = 0.0D0
UZTHST(iwvcnt, l) = THTR(l)
UZSTOR(i, l) = 0.0D0
UZOLSFLX(i, l) = 0.0D0
END IF
C
C35-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN FIRST STRESS PERIOD IS
C TRANSIENT.
ELSE IF ( iss.EQ.0 ) THEN
top = THTI(l) - THTR(l)
IF ( top.LT.CLOSEZERO ) top = 0.0
UZTHST(1, l) = THTI(l)
UZSTOR(1, l) = UZDPST(1, l)*top*WETPER(1, l)*strlen
bottom = THTS(l) - THTR(l)
IF ( bottom.LT.CLOSEZERO .OR. top.LT.CLOSEZERO ) THEN
UZFLST(1, l) = 0.0D0
ELSE
UZFLST(1, l) = UHC(l)*(top/bottom)**EPS(l)
END IF
C
C36-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN FIRST STRESS PERIOD IS
C STEADY STATE.
ELSE
UZTHST(1, l) = THTR(l)
UZSTOR(1, l) = 0.0D0
UZFLST(1, l) = 0.0D0
UZOLSFLX(1, l) = 0.0D0
END IF
iwvcnt = iwvcnt + istep
END DO
C
C37-----INITIALIZE UNSATURATED ZONE ARRAYS TO ZERO WHEN NO UNSATURATED
C ZONE.
ELSE
iwvcnt = 1
istep = NSTOTRL/ISUZN
DO i = 1, ISUZN
UZDPST(iwvcnt, l) = 0.0D0
UZFLST(iwvcnt, l) = 0.0D0
UZSPST(iwvcnt, l) = 0.0D0
UZTHST(1, l) = THTR(l)
iwvcnt = iwvcnt + istep
END DO
END IF
UZOLSFLX(1, l) = UZFLST(1, l)
C
C38-----ONLY ONE UNSATURATED ZONE WIDTH WHEN ICALC IS 1.
ELSE IF ( icalc.EQ.1 ) THEN
WETPER(1, l) = width
C
C39-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN GROUND WATER HEAD
C IS LESS THAN BOTTOM OF STREAMBED.
IF ( sbot.GT.h ) THEN
UZDPST(1, l) = sbot - h
UZSPST(1, l) = 0.0D0
NWAVST(1, l) = 1
C
C40-----INITIALIZE UNSATURATED ZONE ARRAYS FOR SECOND STRESS PERIOD
C WHEN FIRST STRESS PERIOD IS STEADY STATE.
IF ( iflginit.EQ.2 ) THEN
IF ( UZSEEP(1, l).GT.0.0 ) THEN
UZFLST(1, l) = UZSEEP(1, l)
UZTHST(1, l) = (((UZFLST(1,l)/UHC(l))**(1.0D0/EPS(l)))
+ *(THTS(l)-THTR(l))) + THTR(l)
top = UZTHST(1, l) - THTR(l)
IF ( top.LT.CLOSEZERO ) top = 0.0
UZSTOR(1, l) = UZDPST(1, l)*top*WETPER(1, l)*strlen
UZOLSFLX(1, l) = UZSEEP(1, l)
ELSE
UZFLST(1, l) = 0.0D0
UZTHST(1, l) = THTR(l)
UZSTOR(1, l) = 0.0D0
UZOLSFLX(1, l) = 0.0D0
END IF
C
C41-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN FIRST STRESS PERIOD IS
C TRANSIENT.
ELSE IF ( iss.EQ.0 ) THEN
UZTHST(1, l) = THTI(l)
top = THTI(l) - THTR(l)
IF ( top.LT.CLOSEZERO ) top = 0.0
UZSTOR(1, l) = UZDPST(1, l)*top*width*strlen
bottom = THTS(l) - THTR(l)
IF ( bottom.LT.CLOSEZERO .OR. top.LT.CLOSEZERO ) THEN
UZFLST(1, l) = 0.0D0
ELSE
UZFLST(1, l) = UHC(l)*(top/bottom)**EPS(l)
END IF
C
C42-----INITIALIZE UNSATURATED ZONE ARRAYS WHEN FIRST STRESS PERIOD IS
C STEADY STATE.
ELSE
UZTHST(1, l) = THTR(l)
UZSTOR(1, l) = 0.0D0
UZFLST(1, l) = 0.0D0
END IF
ELSE
C
C43-----INITIALIZE UNSATURATED ZONE ARRAYS TO ZERO WHEN NO UNSATURATED
C ZONE.
UZTHST(1, l) = THTR(l)
UZDPST(1, l) = 0.0D0
UZFLST(1, l) = 0.0D0
UZSPST(1, l) = 0.0D0
UZSTOR(1, l) = 0.0D0
END IF
DO ik = 2, NSTOTRL
UZTHST(ik, l) = THTR(l)
END DO
UZOLSFLX(1, l) = UZFLST(1, l)
END IF
END IF
END DO
Cdep Added new subroutine to compute tables for lake outflow
C44-----COMPUTE VALUES FOR ARRAYS DKLOTFLW AND DLKSTAGE WHEN OUTFLOW FROM
C LAKES ARE COMPUTED IN THE LAKE PACKAGE.
IF ( Iunitlak.GT.0 ) THEN
CALL GWF2SFR7LAKOUTFLW(1)
END IF
C
C45-----RETURN.
RETURN
END SUBROUTINE GWF2SFR7RP
C
C-------SUBROUTINE GWF2SFR7FM
SUBROUTINE GWF2SFR7FM(Kkiter, Kkper, Kkstp, Iunitlak, Igrid)
C *****************************************************************
C ADD STREAM TERMS TO RHS AND HCOF IF FLOW OCCURS IN MODEL CELL
C VERSION 7.1.01: February 15, 2009
C *****************************************************************
USE GWFSFRMODULE
USE GLOBAL, ONLY: NLAY, IOUT, ISSFLG, IBOUND, HNEW, HCOF,
+ RHS
USE GWFBASMODULE, ONLY: DELT, TOTIM, HDRY
USE GWFLAKMODULE, ONLY: THETA, STGOLD, STGNEW, VOL
IMPLICIT NONE
INTRINSIC IABS, ABS, DABS, MIN, DSQRT, FLOAT, SQRT, SNGL
C -----------------------------------------------------------------
C SPECIFICATIONS:
C -----------------------------------------------------------------
C FUNCTIONS
C -----------------------------------------------------------------
REAL CALCUNSATFLOBOT
EXTERNAL CALCUNSATFLOBOT
C -----------------------------------------------------------------
C ARGUMENTS
C -----------------------------------------------------------------
INTEGER Kkiter, Kkper, Iunitlak, Igrid, Kkstp
C -----------------------------------------------------------------
C LOCAL VARIABLES
C -----------------------------------------------------------------
DOUBLE PRECISION cstr, cstr1, cstr2, dbleak, dlet1, dlet2, dlfh,
+ dlh, dlpp1, dlpp2, dlwp1, dlwp2, depth, depthx,
+ depthp, deptha, depthb, depthc, depthd, depth1,
+ depth2, dlkstr, deps, et1, et2, fhstr1, fhstr2,
+ flobot, flobot1, flobot2, flowc, flowin, flowot,
+ flwmdpta, flwmdptb, flwmdptc, flwmdptd, flwmdpt1,
+ flwmdpt2, flwmpt, h, hstr, pp1, pp2, sbot, slope,
+ strleak, strtop, trbflw, upflw, wetperm,
+ wetperma, wetpermb, wetpermc, wetpermd, wetperm1,
+ wetperm2, wetpermp, wetpermx, width, widtha,
+ widthb, widthc, widthd, width1, width2, widthp,
+ widthx, bwdth, cdpth, fdpth, awdth, f1, f2, fp,
+ enpt1, enpt2, flwen1, flwen2, flwp, flobotp,
+ flobotold, flwpetp, flwx, flwmpt2, flwest,
+ flwpet1, flwpet2, err, dlhold, precip, etstr,
+ runof, runoff, qa, qb, qc, qd, hstrave, fbot
DOUBLE PRECISION fbcheck, hld, totflwt, sbdthk, thetas, epsilon,
+ thr, thet1, dvrsn
! DOUBLE PRECISION rhsh1, hcofh1, rhsh2, hcofh2
!rsr DOUBLE PRECISION grad, hdiff
REAL areamax, avhc, errold, fks, ha, qcnst, seep,
+ stgon, strlen, roughch, roughbnk, widthch, deltinc, qlat,
+ fltest, Transient_bd
! real fin, fout
INTEGER i, ibflg, ic, icalc, idivseg, iflg, iic, iic2, iic3, iic4,
+ il, ilay, iprior, iprndpth, iprvsg, ir, istsg, itot,itrib,
+ itstr, iwidthcheck, kerp, kss, l, lk, ll, nstrpts, nreach,
+ maxwav, icalccheck, iskip, iss, lsub, numdelt, irt, ii,
+ idr, lfold
DOUBLE PRECISION FIVE_THIRDS
PARAMETER (FIVE_THIRDS=5.0D0/3.0D0)
C -----------------------------------------------------------------
C
C-------SET POINTERS FOR CURRENT GRID.
CALL SGWF2SFR7PNT(Igrid)
C
iss = ISSFLG(Kkper)
numdelt = NUMTIM
C
C1------RETURN IF NO STREAMS (NSTRM<=0).
IF ( NSTRM.LE.0 ) RETURN
maxwav = NSFRSETS*NSTRAIL
C
C2------THERE ARE STREAMS. INITIALIZE SEGMENT INFLOWS AND OUTFLOWS
C TO ZERO FOR LAKE PACKAGE.
itstr = 0
iprvsg = -1
! Temporary until NWT released
idr = 1
C fin = 0.0
C fout = 0.0
IF ( Iunitlak.GT.0 ) THEN
DO i = 1, NSS
STRIN(i) = 0.0
FXLKOT(i) = 0.0
END DO
Cdep Change time weighting factor for lake stage calculation.
Cdep 6/27/2005
IF (iss.NE.1) THEN
thet1 = THETA
ELSE
thet1 = 1.0D0
END IF
END IF
C
C2b-----START INTERNAL TIME LOOP FOR STREAMFLOW ROUTING.
deltinc = DELT
IF ( IRTFLG.GT.0 .AND. iss.EQ.0 ) THEN
deltinc = DELT/FLOAT(numdelt)
ELSE
numdelt = 1
END IF
DO irt = 1, numdelt
C
C3------DETERMINE LAYER, ROW, COLUMN OF EACH REACH.
DO l = 1, NSTRM
lfold = l
IF ( Nfoldflbt==1 ) lfold = 1
flowin = 0.0D0
dvrsn = 0.0D0
! rhsh1 = 0.0d0
! rhsh2 = 0.0d0
! hcofh1 = 0.0d0
! hcofh2 = 0.0d0
Transient_bd = 0.0
IF ( irt.EQ.1 ) THEN
STRM(27,l) = STRM(25,l)
STRM(28,l) = STRM(26,l)
SUMLEAK(l) = 0.0D0
SUMRCH(l) = 0.0D0
END IF
lsub = l
ll = l - 1
il = ISTRM(1, l)
ir = ISTRM(2, l)
ic = ISTRM(3, l)
C
C4------DETERMINE STREAM SEGMENT AND REACH NUMBER.
istsg = ISTRM(4, l)
nreach = ISTRM(5, l)
icalc = ISEG(1, istsg)
! RGN 5/9/09 set slope for all icalc
slope = STRM(2, l)
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) THEN
roughch = SEG(16, istsg)
IF(icalc.EQ.1) widthch = SEG(9, istsg)
IF(icalc.EQ.2) roughbnk = SEG(17, istsg)
END IF
IF ( icalc.EQ.4 ) nstrpts = ISEG(2, istsg)
C
C5------SET FLOWIN EQUAL TO STREAM SEGMENT INFLOW IF FIRST REACH.
IF ( nreach.EQ.1 ) THEN
IF ( ISEG(3, istsg).EQ.5 ) flowin = SEG(2, istsg)
C
C6------STORE OUTFLOW FROM PREVIOUS SEGMENT IN SGOTFLW LIST AND IN
C STRIN FOR LAKE PACKAGE.
IF ( istsg.GT.1 ) THEN
iprvsg = ISTRM(4, ll)
SGOTFLW(iprvsg) = STRM(9, ll)
IF ( Iunitlak.GT.0 ) STRIN(iprvsg) = STRM(9, ll)
END IF
C
C7------COMPUTE INFLOW OF A STREAM SEGMENT EMANATING FROM A LAKE.
IF ( (Iunitlak.GT.0) .AND. (IDIVAR(1,istsg).LT.0) ) THEN
lk = IABS(IDIVAR(1, istsg))
C
C8------CHECK IF LAKE OUTFLOW IS SPECIFIED AT A FIXED RATE.
IF ( SEG(2, istsg).GT.CLOSEZERO .AND.
+ VOL(lk).GT.CLOSEZERO ) THEN
IF( SEG(2, istsg)*DELT-VOL(lk).LT.-CLOSEZERO )THEN
FXLKOT(istsg) = SEG(2, istsg)
ELSE
FXLKOT(istsg) = VOL(lk)/DELT
WRITE(IOUT,9000) lk,FXLKOT(istsg)
9000 FORMAT(/5X, '*** WARNING *** SPECIFIED OUTFLOW ',
+ 'VOLUME FOR TIME STEP IS GREATER THAN ',
+ 'VOLUME IN LAKE ',I5,//' RATE HAS BEEN ',
+ 'DECREASED TO ',1PE15.7)
END IF
flowin = FXLKOT(istsg)
ELSE IF ( SEG(2, istsg).LT.-CLOSEZERO ) THEN
WRITE (IOUT, 9001) istsg
9001 FORMAT (/5X, '*** WARNING *** NEGATIVE LAKE OUTFLOW ',
+ 'NOT ALLOWED; SEG = ', I6, /10X,
+ 'CODE WILL ASSUME FLOW = 0.0'/)
SEG(2, istsg) = 0.0
flowin = SEG(2, istsg)
FXLKOT(istsg) = flowin
END IF
C
C9------SPECIFIED FLOW FROM LAKE IS ZERO AND ICALC IS ZERO.
IF ( icalc.EQ.0 ) THEN
flowin = FXLKOT(istsg)
END IF
C
C9B-----ESTIMATE LAKE OUTFLOW FOR FIRST ITERATION OF SIMULATION.
IF( Kkper.EQ.1 .AND. Kkstp.EQ.1 .AND. Kkiter.EQ.1 ) THEN
stgon = (1.0-thet1)*STGOLD(lk) + thet1*STGNEW(lk)
dlkstr = stgon - SEG(8, istsg)
IF ( FXLKOT(istsg).LE.CLOSEZERO )THEN
C
C10-----FLOW FROM LAKE COMPUTED USING MANNINGS FORMULA AND ASSUMING A
C WIDE RECTANGULAR CHANNEL.
IF ( dlkstr.GT.NEARZERO .AND. icalc.EQ.1 ) THEN
flowin = (CONST/roughch)*widthch
+ *(dlkstr**FIVE_THIRDS)*(DSQRT(slope))
C
C11-----FLOW FROM LAKE COMPUTED USING MANNINGS FORMULA AND EIGHT POINT
C CROSS-SECTIONAL AREA.
ELSE IF ( dlkstr.GT.NEARZERO .AND. icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(dlkstr, istsg, roughch,
+ roughbnk, slope, wetperm,
+ flowin, width)
C
C12-----FLOW FROM LAKE COMPUTED USING FORMULA-- Q=(DEPTH/CDPTH)**1/FDPTH).
ELSE IF ( dlkstr.GT.NEARZERO .AND. icalc.EQ.3 ) THEN
cdpth = SEG(9, istsg)
fdpth = SEG(10, istsg)
flowin = (dlkstr/cdpth)**(1.0D0/fdpth)
C
C13-----FLOW FROM LAKE COMPUTED USING TABULATED VALUES.
ELSE IF ( dlkstr.GT.NEARZERO .AND. icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flowin, dlkstr, width,
+ nstrpts, nreach, istsg,
+ Kkiter, 0)
ELSE IF ( dlkstr.LT.NEARZERO .AND. icalc.GT.0 ) THEN
flowin = 0.0D0
END IF
STROUT(istsg)= flowin
END IF
ELSE IF ( FXLKOT(istsg).LE.CLOSEZERO )THEN
flowin = STROUT(istsg)
END IF
END IF
C
C14-----COMPUTE ONE OR MORE DIVERSIONS FROM UPSTREAM SEGMENT.
Crgn&dep revised computation of diversions and added subroutine
IF( istsg.GT.1 )THEN
DO kss = 2, NSS
upflw = SGOTFLW(istsg-1)
idivseg = kss
IF( IDIVAR(1,kss).EQ.istsg-1 ) THEN
dvrsn = SEG(2,idivseg)
iprior = IDIVAR(2,kss)
CALL GWF2SFR7DIVERS(iprior, upflw, dvrsn)
DVRSFLW(kss) = dvrsn
SGOTFLW(istsg-1) = SGOTFLW(istsg-1) - dvrsn
END IF
END DO
C
C20-----SET FLOW INTO DIVERSION IF SEGMENT IS DIVERSION.
IF( ISEG(3,istsg).EQ.6 ) THEN
IF( IDIVAR(1,istsg).GT.0 ) flowin = DVRSFLW(istsg)
END IF
END IF
C
C21-----SUM TRIBUTARY OUTFLOW AND USE AS INFLOW INTO DOWNSTREAM SEGMENT.
IF ( istsg.GE.1 .AND. ISEG(3, istsg).EQ.7 ) THEN
flowin = 0.0D0
DO itrib = 1, NSS
IF ( istsg.EQ.IOTSG(itrib) ) THEN
trbflw = SGOTFLW(itrib)
flowin = flowin + trbflw
END IF
END DO
flowin = flowin + SEG(2, istsg)
IF ( flowin.LT.-NEARZERO ) THEN
flowin = 0.0D0
WRITE (IOUT, 9002) istsg
9002 FORMAT (//2X, '*** WARNING *** FLOW INTO TRIBUTARY ',
+ 'STREAM SEGMENT No. ', I6, ' WAS NEGATIVE; ',
+ 'FLOWIN RE-SET = 0.0'/)
END IF
END IF
C
C22-----SET INFLOW EQUAL TO OUTFLOW FROM UPSTREAM REACH WHEN REACH
C IS GREATER THAN 1.
ELSE IF ( nreach.GT.1 ) THEN
flowin = STRM(9, ll)
END IF
C
C23-----SEARCH FOR UPPER MOST ACTIVE CELL IN STREAM REACH.
ilay = il
TOPCELL: DO WHILE ( ilay.LE.NLAY )
IF ( IBOUND(ic, ir, ilay).EQ.0 ) THEN
ilay = ilay + 1
ELSE
EXIT TOPCELL
END IF
END DO TOPCELL
IF ( ilay.LE.NLAY ) il = ilay
C30d----BEGIN LOOP FOR NEWTON SOLVER IF ACTIVE (Hardwired inactive until NWT released)
DO ii = 1, idr
SUMLEAK(l) = 0.0D0
SUMRCH(l) = 0.0D0
! IF ( ii.EQ.2 ) h = h + Heps
C
C24-----INITIALIZE VARIABLES.
iprndpth = 0
depth = STRM(7, l)
IF ( depth.LT.NEARZERO ) depth = 0.D0
strtop = STRM(3, l)
sbot = STRM(4, l)
width = STRM(5, l)
wetperm = width
strlen = STRM(1, l)
h = HNEW(ic, ir, il)
hld = HLDSFR(l)
! Added code to test for BCF or LPF 11/19/07
!rsr, modified as hld is double and hdry single
IF ( ABS(SNGL(hld)-HDRY).LT.CLOSEZERO ) hld = h
avhc = STRM(6, l)
sbdthk = STRM(8, l)
hstr = depth + STRM(3, l)
cstr = STRM(16, l)
precip = STRM(14, l)
etstr = STRM(13, l)
runof = STRM(12, l)
runoff = STRM(24, l)
strleak = strlen*avhc
depthx = 0.0D0
dbleak = DLEAK
deps = 0.999*DLEAK
dlh = deps
dlhold = 1.0D6
itot = 0
iskip = 0
! IF ( h.LT.sbot ) THEN
! hdiff = hstr - sbot
!rsr grad = (hdiff)/sbdthk
! ELSE
! hdiff = hstr - h
!rsr grad = (hdiff)/sbdthk
! END IF
IF ( icalc.EQ.1 ) THEN
qcnst = CONST*width*SQRT(slope)/roughch
ELSE IF ( icalc.EQ.3 ) THEN
cdpth = SEG(9, istsg)
fdpth = SEG(10, istsg)
awdth = SEG(14, istsg)
bwdth = SEG(15, istsg)
END IF
C
C25-----INITIALIZE UNSATURATED ZONE VARIABLES.
icalccheck = 0
flobotold = 0.0D0
areamax = 0.0
IF ( IUZT.EQ.1 ) THEN
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) icalccheck = 1
IF ( icalccheck.EQ.1 ) THEN
IF ( icalc.EQ.1 ) THEN
wetperm = STRM(5, l)
areamax = WETPER(1, l)*strlen
UZSEEP(1, l) = 0.0
ELSE IF ( icalc.EQ.2 ) THEN
DO i = 1, ISUZN
UZSEEP(i, l) = 0.0D0
areamax = areamax + WETPER(i, l)*strlen
END DO
END IF
thetas = THTS(l)
fks = UHC(l)
thr = THTR(l)
epsilon = EPS(l)
ha = -.15
totflwt = 0.0D0
fbcheck = 1.0D-12/deltinc
IF ( fbcheck.LT.5.0D-8 ) fbcheck = 5.0D-8
END IF
END IF
C
C26-----SET STREAMBED HYDRAULIC CONDUCTIVITY AND STREAM LEAKAGE TO
C ZERO WHEN NOT AN ACTIVE CELL.
IF ( IBOUND(ic, ir, il).LE.0 ) THEN
avhc = 0.0
strleak = 0.0D0
h = hstr
IF ( icalc.LE.1 ) iskip = 1
END IF
C
C27-----BEGIN COMPUTATION OF STREAM DEPTH FOR ACTIVE CELL.
C
C28-----COMPUTE FLOW AT MIDPOINT OF REACH IGNORING STREAMBED LEAKAGE.
IF ( icalc.EQ.0 ) THEN
flwmpt = flowin + 0.5D0*(runof+runoff-etstr+precip)
Crgn 10/23/06 initialize flowc
flowc = flowin + runof+runoff-etstr+precip
SFRQ(4, l) = width
IF ( flwmpt.LT.NEARZERO ) flwmpt = 0.0D0
END IF
IF ( icalc.EQ.1 ) SFRQ(4, l) = width
IF ( icalc.EQ.1 ) THEN
flowc = flowin + (runof+runoff-etstr+precip)
flwmpt = flowin + 0.5D0*(runof+runoff-etstr+precip)
IF ( flwmpt.LT.NEARZERO ) flwmpt = 0.0D0
IF ( flowc.LT.NEARZERO ) flowc = 0.0D0
depth = (flwmpt/qcnst)**0.6D0
IF ( depth.LT.NEARZERO ) THEN
depth = 0.0D0
hstr = strtop
ELSE
hstr = strtop + depth
END IF
cstr = (avhc*width*strlen)/sbdthk
ELSE IF ( icalc.GE.2 ) THEN
flwmpt = flowin + 0.5*(runof+runoff)
flowc = flowin + runof + runoff
IF ( flowc.LT.NEARZERO ) flowc = 0.0D0
C
C29-----CALCULATE AN INITIAL ESTIMATE OF FLOW IN CHANNEL.
IF ( flwmpt.LT.NEARZERO ) THEN
flwmpt = 0.0D0
depth = 0.0D0
width = 0.0D0
wetperm = 1.0D0
IF ( avhc.LE.CLOSEZERO ) iskip = 1
END IF
IF ( iskip.EQ.0 ) THEN
IF ( flwmpt.LT.NEARZERO .AND. h.GT.strtop ) THEN
flwest = (strlen*avhc/sbdthk)*(ABS(strtop-h))
ELSE
flwest = flwmpt
END IF
IF ( flwest.LT.NEARZERO ) THEN
depth = 0.0D0
width = 1.0D0
wetperm = width
ELSE IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(flwest, slope, istsg, nreach,
+ roughch, roughbnk, wetperm,
+ depth, itstr, width, iprndpth)
ELSE IF ( icalc.EQ.3 ) THEN
depth = cdpth*(flwest**fdpth)
width = awdth*(flwest**bwdth)
wetperm = width
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(flwest, depth, width, nstrpts,
+ istsg)
wetperm = width
END IF
cstr = (avhc*wetperm*strlen)/sbdthk
flowc = flowc + (precip-etstr)*width
END IF
END IF
C
C30-----ESTIMATE DEPTH USING BISECTION METHOD WHEN ICALC IS GREATER THAN 0.
iflg = 1
C
C30b----SKIP NEWTON METHOD WHEN ICALC IS 1 AND SURFACE INFLOW IS ZERO.
IF ( icalc.EQ.1 .AND. hstr.LE.strtop ) iflg = 0
C30c----SKIP NEWTON METHOD WHEN REACH OUTSIDE ACTIVE AREA AND ISKIP IS 1.
IF ( iskip.NE.0 ) iflg = 0
IF ( h.LE.strtop .AND. flowc.LT.NEARZERO ) iflg = 0
IF ( icalc.GE.1 .AND. iflg.EQ.1 ) THEN
C
C31-----ESTIMATE INITIAL ENDPOINTS.
enpt1 = 0.0D0
IF ( depth.GT.NEARZERO ) THEN
IF ( (strtop-h).GT.NEARZERO ) THEN
enpt2 = 0.9D0*depth
ELSE
enpt2 = 1.1D0*depth - (strtop-h)
END IF
ELSE IF ( (strtop-h).GT.NEARZERO ) THEN
enpt2 = 1.0D0
ELSE
enpt2 = 0.99D0*(h-strtop)
END IF
C
C32-----ESTIMATE FLOW AT ENDPOINT1.
IF ( h.GT.strtop ) THEN
flobot1 = cstr*(strtop-h)
flwen1 = flwmpt - 0.5D0*flobot1
ELSE
flobot1 = 0.0D0
flwen1 = flwmpt
END IF
C
C33-----ESTIMATE DEPTH FOR ENDPOINTS WHEN ICALC IS 1.
IF ( icalc.EQ.1 ) THEN
IF ( h.GT.sbot ) THEN
flobot2 = (cstr*(strtop+enpt2-h))
ELSE IF ( icalccheck.EQ.1 ) THEN
flobot2 = CALCUNSATFLOBOT(enpt2, avhc, fks, width,
+ sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobot2 = (cstr*(strtop+enpt2-sbot))
END IF
IF ( flobot2.GT.flowc ) flobot2 = flowc
depth2 = ((flwmpt-0.5D0*flobot2)/qcnst)**0.6D0
depth1 = ((flwmpt-0.5D0*flobot1)/qcnst)**0.6D0
C
C34-----ESTIMATE DEPTH, WIDTH AND WETTED PERIMETER WHEN
C ICALC IS GREATER THAN OR EQUAL TO 2.
ELSE IF ( icalc.GE.2 ) THEN
IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(enpt2, istsg, roughch,
+ roughbnk, slope, wetperm2, flwen2,
+ width2)
ELSE IF ( icalc.EQ.3 ) THEN
flwen2 = (enpt2/cdpth)**(1.0/fdpth)
IF ( flwen2.GT.NEARZERO ) THEN
width2 = awdth*(flwen2**bwdth)
wetperm2 = width2
ELSE
width2 = 0.0D0
wetperm2 = 1.0D0
END IF
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flwen2, enpt2, width2, nstrpts,
+ nreach, istsg, Kkiter, 0)
wetperm2 = width2
END IF
C
C35-----ESTIMATE LEAKAGE THROUGH STREAMBED WHEN ICALC GREATER THAN OR
C EQUAL TO 2.
IF ( width2.GT.NEARZERO ) THEN
flwpet2 = (precip-etstr)*width2
ELSE
flwpet2 = (precip-etstr)
IF ( flwpet2.LT.NEARZERO ) flwpet2 = 0.0D0
END IF
IF ( h.GT.sbot ) THEN
flobot2 = ((avhc*wetperm2*strlen/sbdthk)*(strtop-h))
ELSE IF ( icalccheck.EQ.1 ) THEN
flobot2 = CALCUNSATFLOBOT(enpt2, avhc, fks, wetperm2,
+ sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobot2 = ((avhc*wetperm2*strlen/sbdthk)
+ *(strtop+enpt2-sbot))
END IF
flwmpt2 = flwmpt
IF ( flobot2.GE.flowc+flwpet2 ) THEN
flobot2 = flowc + flwpet2
flwmpt2 = 0.5D0*(flowc+flwpet2)
END IF
flwen2 = flwmpt2
IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(flwen1, slope, istsg, nreach,
+ roughch, roughbnk,
+ wetperm1, depth1, itstr, width1,
+ iprndpth)
ELSE IF ( icalc.EQ.3 ) THEN
depth1 = cdpth*(flwen1**fdpth)
width1 = awdth*(flwen1**bwdth)
wetperm1 = width1
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(flwen1, depth1, width1, nstrpts,
+ istsg)
END IF
C
C36-----SET DEPTH2 AND WIDTH2 TO ZERO, AND WETPERM2 TO ONE WHEN FLOW AT
C ENDPOINT2 IS LESS THAN OR EQUAL TO ZERO.
IF ( flwen2.LT.NEARZERO ) THEN
depth2 = 0.0D0
width2 = 0.0D0
wetperm2 = 1.0D0
C
C37-----OTHERWISE CALCULATE DEPTH2, WIDTH2, AND WETPERM2.
ELSE IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(flwen2, slope, istsg, nreach,
+ roughch, roughbnk,
+ wetperm2, depth2, itstr, width2,
+ iprndpth)
ELSE IF ( icalc.EQ.3 ) THEN
depth2 = cdpth*(flwen2**fdpth)
width2 = awdth*(flwen2**bwdth)
wetperm2 = width2
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(flwen2, depth2, width2, nstrpts,
+ istsg)
END IF
END IF
C
C38-----DETERMINE ROOT FOR ENDPOINT 1 WHEN DEPTH IS GREATER THAN 0.
IF ( depth1.GT.NEARZERO ) THEN
f1 = enpt1 - depth1
ELSE
enpt1 = 0.0D0
width1 = 0.0D0
wetperm1 = 1.0D0
f1 = enpt1 - 0.0D0
C
C39-----DETERMINE ROOT FOR ENDPOINT 2 WHEN DEPTH IS GREATER THAN 0.
END IF
IF ( depth2.GT.NEARZERO ) THEN
f2 = enpt2 - depth2
IF ( f2.LT.NEARZERO ) enpt2 = depth2
ELSE
depth2 = 0.0D0
width2 = 0.0D0
wetperm2 = 1.0D0
f2 = enpt2 - 0.0D0
END IF
iflg = 1
C
C40-----ITERATE THROUGH NEWTON METHOD TO FIND ESTIMATE OF STREAM DEPTH
C AND STREAMBED LEAKAGE WHEN ICALC IS GREATER THAN 0.
depthp = (enpt1+enpt2)*0.5D0
depthx = depthp
iic = 0
iic2 = 0
iic3 = 0
fhstr1 = 0.0D0
fhstr2 = 0.0D0
flobotp = 0.0D0
DO WHILE ( iflg.EQ.1 )
itot = itot + 1
ibflg = 0
depth1 = depthp
depth2 = depth1 + 2.0D0*(deps)
C
C41-----CALCULATE FLOBOT1 AND FLOBOT2 FOR ICALC EQUAL TO 1.
Cdep Corrected depth1+dlh and depth2+dlh to be depth1 and depth2.
IF ( icalc.EQ.1 ) THEN
flwmdpt1 = qcnst*(depth1**FIVE_THIRDS)
flwmdpt2 = qcnst*(depth2**FIVE_THIRDS)
IF ( h.GT.sbot ) THEN
flobot1 = cstr*((depth1+strtop)-h)
flobot2 = cstr*((depth2+strtop)-h)
ELSE IF ( icalccheck.EQ.1 ) THEN
flobot1 = CALCUNSATFLOBOT(depth1, avhc, fks,
+ width, sbdthk, areamax, strlen, fbcheck,
+ NWAVST(:,l), maxwav, FOLDFLBT(lfold))
flobot2 = CALCUNSATFLOBOT(depth2, avhc, fks,
+ width, sbdthk, areamax, strlen, fbcheck,
+ NWAVST(:,l), maxwav, FOLDFLBT(lfold))
ELSE
flobot1 = cstr*((depth1+strtop)-sbot)
flobot2 = cstr*((depth2+strtop)-sbot)
END IF
C
C42-----USE BISECTION WHEN FLOBOT1 IS LIMITED BY FLOW IN CHANNEL.
IF ( flobot1.GE.flowc ) THEN
enpt2 = depthp
depthp = (enpt1+enpt2)*0.5D0
IF ( h.GT.sbot ) THEN
flobotp = cstr*((depthp+strtop)-h)
ELSE
flobotp = cstr*((depthp+strtop)-sbot)
END IF
IF ( 0.5D0*flobotp.GT.flwmpt ) flobotp = flowc
depthx = ((flwmpt-0.5D0*flobotp)/qcnst)**0.6D0
ibflg = 1
ELSE
fhstr1 = (flwmpt-0.5D0*flobot1) - (flwmdpt1)
fhstr2 = (flwmpt-0.5D0*flobot2) - (flwmdpt2)
END IF
ELSE IF ( icalc.GE.2 ) THEN
C
C43-----CALCULATE NEWTON VARIABLES FOR ICALC EQUAL TO 2.
IF ( icalc.EQ.2 ) THEN
deptha = depth1 - (deps*depth1)
IF ( deptha.LT.NEARZERO ) deptha = depth1
depthb = depth1 + (deps*depth1)
IF ( depthb.LT.NEARZERO ) depthb = deps
depth2 = depth1 + (2.D0*deps)
depthc = depth2 - (deps*depth2)
IF ( depthc.LT.NEARZERO ) depthc = depth2
depthd = depth2 + (deps*depth2)
IF ( depthd.LT.NEARZERO ) depthd = deps
CALL GWF2SFR7FLW(deptha, istsg, roughch,
+ roughbnk, slope, wetperma,
+ flwmdpta, widtha)
CALL GWF2SFR7FLW(depthb, istsg, roughch,
+ roughbnk, slope, wetpermb,
+ flwmdptb, widthb)
CALL GWF2SFR7FLW(depthc, istsg, roughch,
+ roughbnk, slope, wetpermc,
+ flwmdptc, widthc)
CALL GWF2SFR7FLW(depthd, istsg, roughch,
+ roughbnk, slope, wetpermd,
+ flwmdptd, widthd)
CALL GWF2SFR7FLW(depth1, istsg, roughch,
+ roughbnk, slope, wetperm1,
+ flwmdpt1, width1)
CALL GWF2SFR7FLW(depth2, istsg, roughch,
+ roughbnk, slope, wetperm2,
+ flwmdpt2, width2)
C
C44-----CALCULATE NEWTON VARIABLES FOR ICALC EQUAL TO 3.
ELSE IF ( icalc.EQ.3 ) THEN
flwmdpt1 = (depth1/cdpth)**(1.0/fdpth)
flwmdpt2 = (depth2/cdpth)**(1.0/fdpth)
IF ( flwmdpt1.GT.NEARZERO ) THEN
width1 = awdth*(flwmdpt1**bwdth)
wetperm1 = width1
ELSE
width1 = 0.0D0
wetperm1 = 1.0D0
END IF
IF ( flwmpt2.GT.NEARZERO ) THEN
width2 = awdth*(flwmdpt2**bwdth)
wetperm2 = width2
ELSE
width2 = 0.0D0
wetperm2 = 1.0D0
END IF
deptha = depth1 - (deps*depth1)
IF ( deptha.LT.NEARZERO ) deptha = depth1
depthb = depth1 + (deps*depth1)
IF ( depthb.LT.NEARZERO ) depthb = deps
depth2 = depth1 + (2*deps)
depthc = depth2 - (deps*depth2)
IF ( depthc.LT.NEARZERO ) depthc = depth2
depthd = depth2 + (deps*depth2)
IF ( depthd.LT.NEARZERO ) depthd = deps
flwmdpta = (deptha/cdpth)**(1.0/fdpth)
flwmdptb = (depthb/cdpth)**(1.0/fdpth)
flwmdptc = (depthc/cdpth)**(1.0/fdpth)
flwmdptd = (depthd/cdpth)**(1.0/fdpth)
widtha = awdth*(flwmdpta**bwdth)
widthb = awdth*(flwmdptb**bwdth)
widthc = awdth*(flwmdptc**bwdth)
widthd = awdth*(flwmdptd**bwdth)
wetperma = widtha
wetpermb = widthb
wetpermc = widthc
wetpermd = widthd
C
C45-----CALCULATE NEWTON VARIABLES FOR ICALC EQUAL TO 4.
ELSE IF ( icalc.EQ.4 ) THEN
deptha = depth1 - (deps*depth1)
IF ( deptha.LT.NEARZERO ) deptha = depth1
depthb = depth1 + (deps*depth1)
IF ( depthb.LT.NEARZERO ) depthb = deps
depthc = depth2 - (deps*depth2)
IF ( depthc.LT.NEARZERO ) depthc = depth2
depthd = depth2 + (deps*depth2)
IF ( depthd.LT.NEARZERO ) depthd = deps
CALL GWF2SFR7TBF(flwmdpta, deptha, widtha,
+ nstrpts, nreach, istsg, Kkiter, 0)
CALL GWF2SFR7TBF(flwmdptb, depthb, widthb,
+ nstrpts, nreach, istsg, Kkiter, 0)
CALL GWF2SFR7TBF(flwmdptc, depthc, widthc,
+ nstrpts, nreach, istsg, Kkiter, 0)
CALL GWF2SFR7TBF(flwmdptd, depthd, widthd,
+ nstrpts, nreach, istsg, Kkiter, 0)
CALL GWF2SFR7TBF(flwmdpt1, depth1, width1,
+ nstrpts, nreach, istsg, Kkiter, 0)
CALL GWF2SFR7TBF(flwmdpt2, depth2, width2,
+ nstrpts, nreach, istsg, Kkiter, 0)
wetperma = widtha
wetpermb = widthb
wetpermc = widthc
wetpermd = widthd
wetperm1 = width1
wetperm2 = width2
END IF
C
C46-----CALCULATE DERIVATIVES FOR DEPTH DEPENDENT VARIABLES FOR ICALC
C GREATER THAN 1.
dlpp1 = (precip*(widtha-widthb))/(deptha-depthb)
dlpp2 = (precip*(widthc-widthd))/(depthc-depthd)
dlet1 = (etstr*(widtha-widthb))/(deptha-depthb)
dlet2 = (etstr*(widthc-widthd))/(depthc-depthd)
dlwp1 = (wetperma-wetpermb)/(deptha-depthb)
dlwp2 = (wetpermc-wetpermd)/(depthc-depthd)
Cdep revised pp1,pp2,et1,and et2, wrong placment of parenthesis.
pp1 = precip*(width1)+dlpp1*dlh
pp2 = precip*(width2)+dlpp2*dlh
et1 = etstr*(width1)+dlet1*dlh
et2 = etstr*(width2)+dlet2*dlh
cstr1 = ((wetperm1+dlwp1*dlh)*strleak)/sbdthk
cstr2 = ((wetperm2+dlwp2*dlh)*strleak)/sbdthk
C
C47-----CALCULATE FLOBOT1 AND FLOBOT2 WHEN ICALC GREATER THAN 1.
IF ( h.GE.sbot ) THEN
flobot1 = cstr1*((depth1+strtop)-h)
flobot2 = cstr2*((depth2+strtop)-h)
ELSE IF ( icalccheck.EQ.1 ) THEN
flobot1 = CALCUNSATFLOBOT(depth1, avhc, fks,
+ wetperm1, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav, FOLDFLBT(lfold))
flobot2 = CALCUNSATFLOBOT(depth2, avhc, fks,
+ wetperm2, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav, FOLDFLBT(lfold))
ELSE
flobot1 = cstr1*((depth1+strtop)-sbot)
flobot2 = cstr2*((depth2+strtop)-sbot)
END IF
C
C48-----DETERMINE IF LEAKAGE LIMITED BY FLOW IN CHANNEL.
IF ( width1.GT.NEARZERO ) THEN
Cdep revised flwpet1, wrong placment of parenthesis.
flwpet1 = precip*width1+(dlpp1*dlh)
+ - etstr*width1+(dlet1*dlh)
ELSE
flwpet1 = (precip-etstr)
IF ( flwpet1.LT.NEARZERO ) flwpet1 = 0.0D0
END IF
C
C49-----USE BISECTION WHEN LEAKAGE IS LIMITED BY FLOW IN CHANNEL.
IF ( flobot1.GT.flowc+flwpet1 ) THEN
depthp = (enpt1+enpt2)*0.5D0
ibflg = 1
IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(depthp, istsg, roughch,
+ roughbnk, slope, wetpermp,
+ flwx, widtha)
ELSE IF ( icalc.EQ.3 ) THEN
flwx = (depthp/cdpth)**(1.0/fdpth)
IF ( flwx.GT.NEARZERO ) THEN
widthp = awdth*(flwx**bwdth)
wetpermp = widthp
ELSE
widthp = 0.0D0
wetpermp = 1.0D0
END IF
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flwx, depthp, widthp,
+ nstrpts, nreach, istsg, Kkiter, 0)
wetpermp = widthp
END IF
cstr1 = wetpermp*strleak/sbdthk
IF ( h.GT.sbot ) THEN
flobotp = cstr1*((depthp+strtop)-h)
ELSE IF ( icalccheck.EQ.1 ) THEN
flobotp = CALCUNSATFLOBOT(depthp, avhc, fks,
+ wetpermp, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobotp = cstr1*((depthp+strtop)-sbot)
END IF
IF ( flobotp.GT.flowc+flwpet1 ) flobotp = flowc
+ + flwpet1
flwmpt = flwmpt + 0.5D0*flwpet1
flwx = flwmpt - 0.5D0*flobotp
IF ( flwx.LT.NEARZERO ) THEN
depthx = 0.0D0
widthx = 0.0D0
wetpermx = 1.0D0
ELSE IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(flwx, slope, istsg, nreach,
+ roughch, roughbnk, wetpermp,
+ depthx, itstr, widthp,iprndpth)
ELSE IF ( icalc.EQ.3 ) THEN
depthx = cdpth*(flwx**fdpth)
Crgn changed widthp to widthx 12/5/06
widthx = awdth*(flwx**bwdth)
wetpermx = widthx
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(flwx, depthx, widthx,
+ nstrpts, istsg)
wetpermx = widthx
END IF
C
C50-----CALCULATE LEAKAGE FROM NEWTON METHOD WHEN NOT LIMITED BY FLOW.
ELSE
fhstr1 = (flwmpt-0.5D0*(pp1-et1+flobot1)) - (flwmdpt1)
fhstr2 = (flwmpt-0.5D0*(pp2-et2+flobot2)) - (flwmdpt2)
END IF
IF ( depthp.LE.dbleak*0.000001D0 ) THEN
depthx = depthp
flobotp = 0.0D0
widthx = 0.0D0
wetpermx = 1.0D0
iflg = 0
END IF
END IF
IF ( ibflg.EQ.0 ) THEN
dlfh = (fhstr1-fhstr2)/(depth1-depth2)
IF ( DABS(dlfh).LE.dbleak ) dlfh = 0.0D0
IF ( DABS(dlfh).GT.NEARZERO ) THEN
dlh = -fhstr1/dlfh
ELSE
dlh = 0.0D0
END IF
depthp = depth1 + dlh
IF ( iflg.GT.0 ) THEN
IF ( (depthp.GE.enpt2) .OR. (depthp.LE.enpt1) ) THEN
IF ( DABS(dlh).GT.DABS(dlhold) .OR.
+ depthp.LT.NEARZERO ) THEN
depthp = (enpt1+enpt2)*0.5D0
ibflg = 1
END IF
END IF
C
C51-----SET FLAGS TO DETERMINE IF NEWTON METHOD OSCILLATES OR
C IF CONVERGENCE IS SLOW.
IF ( flobot1*flobotold.LT.NEARZERO ) THEN
iic2 = iic2 + 1
ELSE
iic2 = 0
END IF
IF ( flobot1.LT.NEARZERO ) THEN
iic3 = iic3 + 1
ELSE
iic3 = 0
END IF
IF ( dlh*dlhold.LT.NEARZERO .OR.
+ DABS(dlh).GT.DABS(dlhold) ) iic = iic + 1
iic4 = 0
IF ( iic3.GT.7 .AND. iic.GT.12 ) iic4 = 1
C
C52-----SWITCH TO BISECTION WHEN NEWTON METHOD OSCILLATES OR WHEN
C CONVERGENCE IS SLOW.
IF ( iic2.GT.7 .OR. iic.GT.12 .OR. iic4.EQ.1 ) THEN
ibflg = 1
depthp = (enpt1+enpt2)*0.5D0
END IF
C
C53-----COMPUTE FLOBOTP ON BASIS OF DEPTHP AND THEN ESTIMATE DEPTHX FROM
C FLOBOTP.
IF ( icalc.EQ.1 ) THEN
IF ( h.GT.sbot ) THEN
flobotp = (cstr*(strtop+depthp-h))
ELSE IF ( icalccheck.EQ.1 ) THEN
flobotp = CALCUNSATFLOBOT(depthp, avhc, fks,
+ width, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobotp = (cstr*(strtop+depthp-sbot))
END IF
IF ( flobotp.GE.flowc ) THEN
flobotp = flowc
IF ( DABS(enpt1-enpt2).LE.dbleak*0.000001D0 )
+ depthp = ((flwmpt-0.5D0*flobotp)/qcnst)**.6D0
END IF
depthx = ((flwmpt-0.5D0*flobotp)/qcnst)**0.6D0
ELSE IF ( icalc.GE.2 ) THEN
IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(depthp, istsg, roughch, roughbnk,
+ slope, wetpermp, flwp, widthp)
ELSE IF ( icalc.EQ.3 ) THEN
flwp = (depthp/cdpth)**(1.0/fdpth)
IF ( flwp.GT.NEARZERO ) THEN
widthp = awdth*(flwp**bwdth)
wetpermp = widthp
ELSE
widthp = 0.0D0
wetpermp = 1.0D0
END IF
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flwp, depthp, widthp,
+ nstrpts, nreach, istsg,
+ Kkiter, 0)
wetpermp = widthp
END IF
IF ( widthp.GT.NEARZERO ) THEN
flwpetp = (precip-etstr)*widthp
ELSE
flwpetp = (precip-etstr)
IF ( flwpetp.LT.NEARZERO ) flwpetp = 0.0D0
END IF
IF ( h.GT.sbot ) THEN
flobotp = ((avhc*wetpermp*strlen/sbdthk)
+ *(strtop+depthp-h))
ELSE IF ( icalccheck.EQ.1 ) THEN
flobotp = CALCUNSATFLOBOT(depthp, avhc, fks,
+ wetpermp, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobotp = ((avhc*wetpermp*strlen/sbdthk)
+ *(strtop+depthp-sbot))
END IF
flwmpt = flwmpt + 0.5D0*flwpetp
flwx = flwmpt - 0.5D0*flobotp
C
C54-----USE BISECTION WHEN LEAKAGE LIMITED BY FLOW FOR ICALC GREATER
C OR EQUAL TO 2.
IF ( flobotp.GT.flowc+flwpetp ) THEN
depthp = (enpt1+enpt2)*0.5D0
ibflg = 1
IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(depthp, istsg, roughch,
+ roughbnk, slope, wetpermp,
+ flwp, widthp)
ELSE IF ( icalc.EQ.3 ) THEN
flwp = (depthp/cdpth)**(1.0/fdpth)
IF ( flwp.GT.NEARZERO ) THEN
widthp = awdth*(flwp**bwdth)
wetpermp = widthp
ELSE
widthp = 0.0D0
wetpermp = 1.0D0
END IF
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flwp, depthp, widthp,
+ nstrpts, nreach, istsg,
+ Kkiter, 0)
wetpermp = widthp
END IF
IF ( widthp.GT.NEARZERO ) THEN
flwpetp = (precip-etstr)*widthp
ELSE
flwpetp = (precip-etstr)
IF ( flwpetp.LT.NEARZERO ) flwpetp = 0.0D0
END IF
IF ( h.GT.sbot ) THEN
flobotp = ((avhc*wetpermp*strlen/sbdthk)
+ *(strtop+depthp-h))
ELSE IF ( icalccheck.EQ.1 ) THEN
flobotp = CALCUNSATFLOBOT(depthp, avhc, fks,
+ wetpermp, sbdthk, areamax, strlen,
+ fbcheck, NWAVST(:,l), maxwav,
+ FOLDFLBT(lfold))
ELSE
flobotp = ((avhc*wetpermp*strlen/sbdthk)
+ *(strtop+depthp-sbot))
END IF
flwmpt = flwmpt + 0.5D0*flwpetp
flwx = flwmpt - 0.5D0*flobotp
IF ( flobotp.GE.flowc+flwpetp ) flobotp = flowc +
+ flwpetp
END IF
C
C55-----ESTIMATE DEPTHX WHEN ICALC IS GREATER THAN OR EQUAL TO 2.
IF ( flwx.LT.NEARZERO ) THEN
depthx = 0.0D0
widthx = 0.0D0
wetpermx = 1.0D0
ELSE IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(flwx, slope, istsg, nreach,
+ roughch, roughbnk, wetpermx,
+ depthx, itstr, widthx, iprndpth)
ELSE IF ( icalc.EQ.3 ) THEN
depthx = cdpth*(flwx**fdpth)
widthx = awdth*(flwx**bwdth)
wetpermx = widthx
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(flwx, depthx, widthx,
+ nstrpts, istsg)
wetpermx = widthx
END IF
END IF
END IF
END IF
C
C56-----COMPUTE DIFFERENCE BETWEEN DEPTHP AND DEPTHX.
fp = depthp - depthx
IF ( ibflg.EQ.1 ) dlh = fp
C
C57-----CHANGE ENDPOINTS IF BISECTION HAS BEEN USED.
IF ( ibflg.EQ.1 ) THEN
IF ( f1*fp.LT.0.0D0 ) THEN
C
C58-----ROOT IS BETWEEN F1 AND FP.
enpt2 = depthp
f2 = fp
ELSE
C
C59-----ROOT IS BETWEEN FP AND F2.
enpt1 = depthp
f1 = fp
C
C60-----CALCULATE ERROR.
END IF
err = MIN(DABS(fp), DABS(enpt2-enpt1))
ELSE
err = dlh
END IF
C
C61-----SET DEPTH TO DEPTHP AND FLOBOT TO FLOBOTP WHEN IS ERROR LESS
C THAN TOLERANCE.
IF ( DABS(err).LT.dbleak ) THEN
iflg = 0
depth = depthp
flobot = flobotp
IF ( icalc.GE.2 ) THEN
width = widthp
wetperm = wetpermp
flowc = flowin + runof + runoff - etstr*width +
+ precip*width
flwmpt = flowin +
+ 0.5D0*(runof+runoff+precip*width-etstr*width-
+ flobot)
!dep August 26, 2009 added ELSE to recalculate flwmpt for ICALC=0 or 1
ELSE
flowc = flowin + runof + runoff - etstr +
+ precip
flwmpt = flowin +
+ 0.5D0*(runof+runoff+precip-etstr-flobot)
END IF
END IF
C
C62-----PRINT WARNING THAT REACH FAILED TO CONVERGE AFTER 100 ITERATIONS.
C AND SET DEPTH TO DEPTHP AND FLOBOT TO FLOBOTP.
IF ( itot.GE.100 ) THEN
iflg = 0
WRITE (IOUT, 9003) istsg, nreach, Kkiter, err, errold
9003 FORMAT (//5X, '*** WARNING *** SFR FAILED TO ',
+ 'CONVERGE FOR SEGMENT', I7, ' REACH NO.', I7,
+ ' MODFLOW ITERATION IS', I7, ' LAST ITERATION',
+ G21.10, ' PREVIOUS ITERATION', G21.10)
depth = depthp
flobot = flobotp
IF ( icalc.GE.2 ) THEN
width = widthp
wetperm = wetpermp
flowc = flowin + runof + runoff - etstr*width +
+ precip*width
flwmpt = flowin +
+ 0.5D0*(runof+runoff+precip*width-etstr*width-
+ flobot)
!dep August 26, 2009 added ELSE to recalculate flwmpt for ICALC=0 or 1
ELSE
flowc = flowin + runof + runoff - etstr + precip
flwmpt = flowin +
+ 0.5D0*(runof + runoff + precip-etstr-flobot)
END IF
END IF
errold = err
dlhold = dlh
flobotold = flobot1
IF ( ibflg.EQ.1 ) flobotold = flobotp
SFRQ(4, l) = width
C
C63-----END OF NEWTON LOOP.
END DO
C
C64-----DEFINE HSTR, CSTR, WIDTH, AND FLOWOT.
hstr = depth + STRM(3, l)
IF ( icalc.GE.2 ) cstr = (avhc*wetperm*strlen)/sbdthk
END IF
C
C65-----ROUTE FLOW WITHOUT ANY STREAM LEAKAGE (FLOBOT IS ZERO) WHEN
C MODEL CELL IS INACTIVE. Revised dep 5/19/2005
IF ( iskip.NE.0 .OR. itot.EQ.0 ) THEN
IF ( icalc.EQ.0 .OR. icalc.EQ.1 ) THEN
flowc = flowin + runof + runoff + (precip-etstr)
flwmpt = flowin + 0.5D0*(runof+runoff+(precip-etstr))
!FLOW AT MIDPOINT CANNOT BE LESS THAN ZERO.
IF( flwmpt.LT.NEARZERO ) flwmpt = 0.0D0
! RGN 10/3/07 added check for flwmpt to avoid NaN values.
IF ( icalc.EQ.1 .AND. flwmpt.GT.NEARZERO ) THEN
depth = (flwmpt/qcnst)**0.6D0
ELSE
depth = 0.0
END IF
IF ( flowc.GT.NEARZERO ) THEN
IF ( runof.LT.NEARZERO ) THEN
IF ( flowin+runoff+precip.GT.NEARZERO ) THEN
IF ( flowin+runoff+precip-etstr.LE.-(runof) ) THEN
runof = -(flowin+runoff+precip-etstr)
ELSE IF ( flowin+runoff+precip+runof.LE.etstr ) THEN
etstr = flowin + runoff + precip + runof
END IF
END IF
ELSE IF ( flowin+runoff+precip+runof.LE.etstr ) THEN
etstr = flowin + runof + runoff + precip - flobot
ELSE IF ( flowin+runoff+precip+runof.LT.NEARZERO ) THEN
etstr = 0.0D0
END IF
flowc = flowin + runof + runoff + precip - etstr
ELSE IF ( runof.LT.NEARZERO ) THEN
IF ( flowin+runoff+precip.LT.NEARZERO ) THEN
runof = 0.0D0
etstr = 0.0D0
ELSE IF ( flowin+runoff+precip-etstr.LE.-(runof) ) THEN
runof = -(flowin+runoff+precip-etstr)
ELSE IF ( flowin+runoff+precip+runof.LE.etstr ) THEN
etstr = flowin + runoff + precip + runof
END IF
ELSE IF ( etstr.GE.flowin+runof+runoff+precip ) THEN
etstr = flowin + runof + runoff + precip
ELSE
etstr = 0.0D0
END IF
ELSE IF ( icalc.GE.2 ) THEN
depth = 0.0D0
cstr = 0.0D0
crgn used width in calculations.
IF ( icalc.EQ.2 ) THEN
width = XSEC(6, istsg) - XSEC(3, istsg)
ELSE IF ( icalc.EQ.3 ) THEN
width = 10.0D0
ELSE IF ( icalc.EQ.4 ) THEN
width = QSTAGE((1+2*nstrpts), istsg)
+ + QSTAGE(3*nstrpts, istsg)/2.0D0
END IF
flowc = flowin + runoff + runof + (precip-etstr)*width
!dep August 26, 2009 fixed flwmpt calculation not half of flowc
flwmpt = flowin +
+ 0.5D0* (runoff+runof+(precip-etstr)*width)
IF ( flowc.LT.NEARZERO ) THEN
flowc = 0.0D0
etstr = (flowin + runoff + runof)/width + precip
flwmpt = 0.0D0
END IF
END IF
C
C66-----COMPUTE STREAM LEAKAGE IF STREAM DEPTH WAS NOT COMPUTED
C USING EITHER BISECTION OR NEWTON METHOD. revised dep
IF ( iskip.EQ.0 ) THEN
cstr = strleak*width/sbdthk
crgn added next 4 lines.
IF (icalc.GT.1 ) THEN
etstr = etstr*width
precip = precip*width
END IF
IF ( flowc.LT.NEARZERO ) THEN
hstr = STRM(3, l)
IF ( h.LT.hstr ) THEN
flobot = 0.0D0
ELSE
flobot = cstr*(hstr-h)
IF ( runof.LT.NEARZERO ) THEN
IF ( flowin+runoff+precip-flobot.LT.NEARZERO ) THEN
runof = 0.0D0
etstr = 0.0D0
ELSE IF ( flowin+runoff+precip-flobot-etstr.LE.
+ -runof ) THEN
runof = -(flowin+runoff+precip-flobot-etstr)
ELSE IF ( flowin+runoff+precip-flobot+runof.LE.
+ etstr ) THEN
etstr = flowin + runoff + precip - flobot + runof
END IF
ELSE IF ( flowin+runoff+runof+precip-flobot.LE.etstr )
+ THEN
etstr = flowin + runof + runoff + precip - flobot
ELSE IF ( flowin+runoff+runof+precip-flobot.LT.
+ NEARZERO ) THEN
etstr = 0.0D0
END IF
END IF
flowc = flowin + runof + runoff + precip - etstr
ELSE IF ( h.LT.sbot ) THEN
flobot = cstr*(hstr-sbot)
ELSE
flobot = cstr*(hstr-h)
END IF
ELSE
flobot = 0.0D0
END IF
END IF
IF ( flowc.GT.NEARZERO .AND. icalccheck.EQ.1 ) THEN
IF ( h.LT.sbot ) THEN
flobot = CALCUNSATFLOBOT(depth, avhc, fks, wetperm,
+ sbdthk, areamax, strlen, fbcheck, NWAVST(:,l),
+ maxwav, FOLDFLBT(lfold))
ELSE
DO i = 1, ISUZN
UZSEEP(i, l) = 0.0D0
END DO
END IF
ELSE IF ( icalccheck.EQ.1 ) THEN
DO i = 1, ISUZN
UZSEEP(i, l) = 0.0D0
END DO
END IF
IF ( flobot.GE.flowc ) flobot = flowc
C
C67-----ROUTE FLOW DOWN CHANNEL WHEN ACTIVE.
IF ( IRTFLG.NE.0 .AND. iss.EQ.0 ) THEN
qlat = (runof + runoff + precip - etstr)/strlen
qa = STRM(28,l)
qb = STRM(27,l)
IF ( ABS(TOTIM-DELT).LT.1.0E-10 ) qb = 0.0
IF ( ABS(TOTIM-DELT).LT.1.0E-10 ) qa = 0.0
qc = flowin
fltest = 0.0
IF ( flobot.LT.0.0D0 ) THEN
fltest=qa+qb+qc+qlat*strlen-flobot
ELSE
fltest=qa+qb+qc+qlat*strlen
END IF
IF ( fltest.GT.NEARZERO ) THEN
CALL ROUTE_CHAN(qa, qb, qc, qd, qcnst, cdpth, awdth,
+ fdpth, bwdth, deltinc, icalc, strlen, slope,
+ istsg, nreach, itstr, qlat, flobot, width, l,
+ Transient_bd)
ELSE
qd = 0.0
END IF
STRM(28,l) = qc
! IF ( qc-flobot.LT.NEARZERO ) THEN
! flobot = cstr*(hdiff)
! IF ( 0.5*flobot.GT.qd ) THEN
! flobot = qd
! qd = 0.0
! flowc = flobot
! ELSE
! qd = qd - 0.5*flobot
! IF (flowc.LT.flobot)flowc = flobot
! END IF
! END IF
STRM(27,l) = qd
flowot = qd
flowc = qc
QSTRM(l,irt) = (qc + qd)/2.0
STRMDELSTOR_RATE = STRMDELSTOR_RATE +
+ (qc + qd)/2.0 - (qa + qb)/2.0
STRMDELSTOR_CUM = STRMDELSTOR_CUM +
+ ((qc + qd)/2.0 - (qa + qb)/2.0)*deltinc
ELSE
C
C68-----STREAMFLOW OUT EQUALS STREAMFLOW IN MINUS LEAKAGE.
flowot = flowc - flobot
IF ( flowot.LT.NEARZERO ) THEN
flowot = 0.0D0
flobot = flowc
flwmpt = 0.5D0*flowc
depth = 0.0D0
END IF
END IF
! rgn 2/12/08 to address bug found by Arlen for SS dependency on DELT
IF ( ISS.EQ.0 ) THEN
SUMLEAK(l) = SUMLEAK(l) + (flobot*deltinc)
IF ( irt.EQ.numdelt) SUMLEAK(l) = SUMLEAK(l)/DELT
ELSE
SUMLEAK(l) = flobot
END IF
C
C
C69-----STORE STREAM INFLOW, OUTFLOW, LEAKAGE, STAGE, AND STREAMBED
C CONDUCTANCE FOR EACH REACH.
STRM(9, l) = flowot
STRM(10, l) = flowin
STRM(11, l) = flobot
STRM(15, l) = hstr
STRM(16, l) = cstr
IF ( icalc.GE.1 ) STRM(7, l) = depth
IF ( icalc.GE.2 ) STRM(5, l) = width
IF ( icalc.GE.2 ) STRM(20, l) = wetperm
HSTRM(l,irt) = hstr
HWDTH(l,irt) = width
HWTPRM(l,irt) = wetperm
C70-----STORE OUTFLOW FROM LAST REACH IN LAST SEGMENT IN STRIN
C LIST FOR LAKE PACKAGE.
IF ( Iunitlak.GT.0 ) THEN
IF ( l.EQ.NSTRM .AND. istsg.EQ.NSS ) STRIN(istsg) = flowot
END IF
C
C71-----STORE OUTFLOW FOR LAST SEGMENT IN SGOTFLW LIST AND IN
C STRIN FOR LAKE PACKAGE.
IF ( l.EQ.NSTRM ) THEN
SGOTFLW(istsg) = STRM(9, l)
IF ( Iunitlak.GT.0 ) STRIN(istsg) = STRM(9, l)
END IF
IF ( irt.EQ.numdelt ) THEN
C
C72-----CALCULATE SEEPAGE THROUGH UNSATURATED ZONE.
IF ( h.LT.sbot .AND. icalccheck.EQ.1 ) THEN
fbot = SUMLEAK(l)
CALL CALC_UNSAT_INFIL(fbot, UZSEEP(:,l),
+ UZTHST(:,l),thr, ha, thetas,
+ epsilon, fks,avhc, depth, sbdthk,
+ WETPER(:,l), UZWDTH(:,l), flowc,
+ NWAVST(:,l),strlen, iwidthcheck,
+ icalc)
END IF
C
C73-----ROUTE SEEPAGE THROUGH UNSATURATED ZONE.
kerp = 0
IF ( h.LT.sbot .OR. hld.LT.sbot ) kerp = 1
IF ( kerp.EQ.1 .AND. iss.EQ.0 .AND. icalccheck.EQ.1 ) THEN
CALL ROUTWAVESIT(lsub, seep, h, hld, thr, thetas, fks,
+ epsilon, icalc, NWAVST(:,l), UZWDTH(:,l),
+ UZFLWT(:,l), UZOLSFLX(:,l), UZSEEP(:,l),
+ ITRLST(:,l), LTRLST(:,l), UZSPST(:,l),
+ UZFLST(:,l), UZDPST(:,l), UZTHST(:,l),
+ ITRLIT(:,l), LTRLIT(:,l), UZSPIT(:,l),
+ UZFLIT(:,l), UZDPIT(:,l), UZTHIT(:,l),
+ DELT, Sbot)
C
C74-----SUM SEEPAGE TO WATER TABLE.
totflwt = 0.0D0
IF ( icalc.EQ.2 ) THEN
DO i = 1, ISUZN
totflwt = totflwt + UZFLWT(i, l)
END DO
ELSE IF ( icalc.EQ.1 ) THEN
totflwt = UZFLWT(1, l)
END IF
SUMRCH(l) = SUMRCH(l) + totflwt/DELT
END IF
IF ( icalccheck.EQ.0 ) THEN
IF ( h.LT.sbot )
+ SUMRCH(l) = SUMRCH(l) + flobot
ELSE IF ( iss.NE.0 ) THEN
IF ( h.LT.sbot )
+ SUMRCH(l) = SUMRCH(l) + flobot
END IF
END IF
C
C75-----STORE FLOWS NEEDED FOR SENSITIVITIES. - ERB
! IF ( ii.EQ.1 ) THEN
SFRQ(1, l) = flwmpt
SFRQ(2, l) = flowc
SFRQ(3, l) = flobot
SFRQ(5, l) = flowin
! END IF
C
C76-----ADD TERMS TO RHS AND HCOF IF FLOBOT IS NOT ZERO.
IF ( irt.EQ.numdelt ) THEN
hstrave = 0.0D0
DO i = 1, numdelt
hstrave = hstrave + HSTRM(l,i)
END DO
hstrave = hstrave/FLOAT(numdelt)
IF ( ABS(SUMLEAK(l)).GT.0.0 ) THEN
C
C77-----ADD TERMS TO RHS AND HCOF WHEN GROUND-WATER HEAD LESS THAN
C STREAMBED BOTTOM ELEVATION.
IF ( h.LT.sbot ) THEN
! IF ( ii.EQ.1 ) THEN
RHS(ic, ir, il) = RHS(ic, ir, il) - SUMRCH(l)
! rhsh1 = - SUMRCH(l)
! ELSEIF ( ii.EQ.2 ) THEN
! rhsh2 = - SUMRCH(l)
! END IF
! fin=fin+sumrch(l)
! write(iout,*)l,sumrch(l)
cdep changed dbleak to -CLOSEZERO
ELSE IF ( SUMLEAK(l)-flowc.LT.-CLOSEZERO ) THEN
C
C78-----STREAM LEAKAGE IS NOT HEAD DEPENDENT.
IF ( iss.EQ.0 ) THEN
! IF ( ii.EQ.1 ) THEN
RHS(ic, ir, il) = RHS(ic, ir, il) -
+ (cstr*hstrave)- SUMRCH(l)
! rhsh1 = - (cstr*hstrave)- SUMRCH(l)
! ELSEIF ( ii.EQ.2 ) THEN
! rhsh2 = - (cstr*hstrave)- SUMRCH(l)
! END IF
! if (hstrave.gt.h)fin=fin+sumrch(l)+cstr*(hstrave-h)
! if( hstrave.lt.h)then
! fout=fout+cstr*(hstrave-h)
! fin=fin+sumrch(l)
! end if
ELSE
! IF ( ii.EQ.1 ) THEN
RHS(ic, ir, il) = RHS(ic, ir, il) -
+ (cstr*hstrave)
! rhsh1 = - (cstr*hstrave)
! ELSEIF ( ii.EQ.2 ) THEN
! rhsh2 = - (cstr*hstrave)
! END IF
! if (hstrave.gt.h)then
! fin=fin+cstr*(hstrave-h)
! end if
! if (hstrave.ge.h)then
! fout=fout+cstr*(hstrave-h)
! write(iout,*)l,cstr*(hstrave-h)
! end if
END IF
! IF ( ii.EQ.1 ) THEN
HCOF(ic, ir, il) = HCOF(ic, ir, il) - cstr
! hcofh1 = - cstr
! ELSEIF ( ii.EQ.2 ) THEN
! hcofh2 = - cstr
! END IF
ELSE
C
C79-----CONSTANT STREAMBED LEAKAGE IS LIMITED BY STREAMFLOW OR
C STREAMBED CONDUCTANCE IN REACH.
IF ( iss.EQ.0 ) THEN
! IF ( ii.EQ.1 ) THEN
RHS(ic, ir, il) = RHS(ic, ir, il)
+ - SUMLEAK(l)- SUMRCH(l)
! rhsh1 = - SUMLEAK(l)- SUMRCH(l)
! ELSEIF ( ii.EQ.2 ) THEN
! rhsh2 = - SUMLEAK(l)- SUMRCH(l)
! END IF
! fin=fin+sumleak(l)+sumrch(l)
ELSE
! IF ( ii.EQ.1 ) THEN
RHS(ic, ir, il) = RHS(ic, ir, il) - SUMLEAK(l)
! rhsh1 = - SUMLEAK(l)
! ELSEIF ( ii.EQ.2 ) THEN
! rhsh2 = - SUMLEAK(l)
! END IF
! fin=fin+sumleak(l)
END IF
C
C80-----ADD TERM ONLY TO RHS WHEN GROUND-WATER HEAD IS LESS THAN
C STREAMBED BOTTOM ELEVATION.
END IF
ELSE IF ( h.LT.sbot .OR. hld.LT.sbot ) THEN
! IF ( ii.EQ.1 )THEN
RHS(ic, ir, il) = RHS(ic, ir, il) - SUMRCH(l)
! rhsh1 = - SUMRCH(l)
! ELSEIF ( ii.EQ.2 )THEN
! rhsh2 = - SUMRCH(l)
! END IF
! fin=fin+sumrch(l)
! write(iout,*)l,sumrch(l)
END IF
END IF
C64B----END NEWTON SOLVER LOOP (NWT PACKAGE)
END DO !rsr, end ii loop
END DO !rsr, end l = 1, NSTRM loop
C
C81-----END INTERNAL TIME LOOP FOR ROUTING STREAMFLOWS.
END DO !rsr, end irt loop
C
C82-----RETURN.
RETURN
END SUBROUTINE GWF2SFR7FM
C
C-------SUBROUTINE GWF2SFR7BD
SUBROUTINE GWF2SFR7BD(Kkstp, Kkper, Iunitgwt, Iunitlak, Iunitgage,
+ Iunituzf, Nsol, Igrid)
C *****************************************************************
C CALCULATE VOLUMETRIC GROUND-WATER BUDGET FOR STREAMS AND SUM
C STREAMFLOWS IN MODELED AREA
C VERSION 7.1.01: February 15, 2009
C *****************************************************************
USE GWFSFRMODULE
USE GWFLAKMODULE, ONLY: VOL
USE GLOBAL, ONLY: NCOL, NROW, NLAY, IOUT, ISSFLG, IBOUND,
+ HNEW, BUFF
USE GWFBASMODULE, ONLY: MSUM, ICBCFL, IBUDFL, DELT, PERTIM, TOTIM,
+ VBVL, VBNM, HDRY
IMPLICIT NONE
INTRINSIC FLOAT, ABS, IABS, DSQRT, DLOG10, SQRT, SNGL
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C FUNCTIONS
C ------------------------------------------------------------------
REAL CALCUNSATFLOBOT
EXTERNAL CALCUNSATFLOBOT
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Kkstp, Kkper, Iunitgwt, Iunitlak, Iunitgage, Iunituzf
INTEGER Igrid, Nsol
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL areamax, avhc, fks, ha, rin, rout, strlen,
+ zero, sfrbudg_in, sfrbudg_out, qlat, deltinc, qcnst, rtime,
+ fltest, Transient_bd, Transient_bd_tot
INTEGER i, ibd, iblst, ibdlbl, ibdst, ibstlb, ic, icalc, idivseg,
+ il, ilay, iout1, iout2, iprior, iprvsg, ir, istsg, itrib,
+ iwidthcheck, kss, l, lk, ll, nreach, numdelt, maxwav,
+ icalccheck, iss, lsub, irt, itstr, imassroute, lfold
DOUBLE PRECISION h, hstr, sbot, cstr, ratin, ratout, flowin,
+ flobot, flow, flowot, sbdthk, upflw, trbflw,
+ width, wetperm, runof, runoff, precip, etstr,
+ slope, cdpth, fdpth, hdiff, grad, depth,
+ hld, fbcheck, totflwt, totdelstor, totuzstor,
+ thetas, epsilon, thr, qa, qb, qc, qd, awdth,
+ bwdth, gwflow, dvrsn, fbot
C ------------------------------------------------------------------
C LOCAL STATIC VARIABLES
C ------------------------------------------------------------------
!rsr DOUBLE PRECISION FIVE_THIRDS
!rsr PARAMETER (FIVE_THIRDS=5.0D0/3.0D0)
CHARACTER*16 text, strtxt, txtlst
DATA text/' STREAM LEAKAGE'/
DATA strtxt/'STREAMFLOW OUT '/
DATA txtlst/'STREAM LISTING '/
DATA iwidthcheck/1/
C -----------------------------------------------------------------
C
C-------SET POINTERS FOR THE CURRENT GRID.
CALL SGWF2SFR7PNT(Igrid)
C
C1------INITIALIZE CELL BY CELL FLOW TERM FLAG (IBD) AND
C ACCUMULATORS (RATIN AND RATOUT).
iss = ISSFLG(Kkper)
ibd = 0
ibdst = 0
iblst = 0
zero = 0.
ratin = zero
ratout = zero
sfrbudg_in = zero
sfrbudg_out = zero
numdelt = NUMTIM
itstr = 0
STRMDELSTOR_RATE = 0.0E0
SFRRATIN = zero
SFRRATOUT = zero
TOTSPFLOW = 0.0D0
Transient_bd_tot = 0.0
Transient_bd = 0.0
lfold = 0
maxwav = NSFRSETS*NSTRAIL
IF ( IUZT.EQ.1 ) THEN
SFRUZBD(4) = zero
SFRUZBD(5) = zero
SFRUZBD(6) = zero
SFRUZBD(7) = zero
SFRUZBD(8) = zero
SFRUZBD(9) = zero
SFRUZBD(10) = zero
END IF
C
C1b-----PRINT STREAM RESULTS WHENEVER BUDGET TERMS ARE PRINTED.
Cdep revised to allow for compact and non compact budgets
IF ( ISTCB1.EQ.-1 .AND. ICBCFL.NE.0 ) THEN
ibd = -1
iblst = -1
ELSE IF ( ISTCB1.EQ.-1 .AND. IBUDFL.GT.0 ) THEN
iblst = -1
ELSE IF ( ISTCB1.GT.0 .AND. ICBCFL.NE.0 ) THEN
ibd = ICBCFL
iout1 = ISTCB1
END IF
IF ( ISTCB2.GT.0 .AND. ICBCFL.NE.0 ) THEN
ibdst = -1
iout2 = ISTCB2
ELSE IF ( ISTCB2.LT.0 .AND. ICBCFL.NE.0 ) THEN
ibdst = ICBCFL
iout2 = ABS(ISTCB2)
END IF
ibdlbl = 0
ibstlb = 0
C
C2------WRITE HEADER WHEN CELL-BY-CELL FLOWS WILL BE SAVED AS A LIST.
IF ( ibd.EQ.2 ) CALL UBDSV2(Kkstp, Kkper, text, iout1, NCOL, NROW,
+ NLAY, NSTRM, IOUT, DELT, PERTIM,
+ TOTIM, IBOUND)
IF ( ibdst.EQ.2 ) CALL UBDSV2 (Kkstp, Kkper, strtxt, iout2, NCOL,
+ NROW, NLAY, NSTRM, IOUT, DELT,
+ PERTIM, TOTIM, IBOUND)
C
C3------CLEAR BUFFERS.
DO il = 1, NLAY
DO ir = 1, NROW
DO ic = 1, NCOL
BUFF(ic, ir, il) = zero
END DO
END DO
END DO
C
C4------INITIALIZE SEGMENT INFLOWS AND OUTFLOWS TO ZERO FOR LAKE PACKAGE
C WHEN THERE ARE STREAMS.
iprvsg = -1
IF ( Iunitlak.GT.0 ) THEN
DO i = 1, NSS
STRIN(i) = 0.0
Cdep STROUT(i) = 0.0
FXLKOT(i) = 0.0
END DO
END IF
C
C5-----START INTERNAL TIME LOOP FOR ROUTING STREAMFLOWS.
deltinc = DELT
IF ( IRTFLG .GT. 0 .AND. iss.EQ.0 ) THEN
deltinc = DELT/FLOAT(numdelt)
ELSE
numdelt = 1
END IF
imassroute = 0
DO irt = 1, numdelt
rtime = TOTIM - DELT + irt*deltinc
IF ( irt.EQ.numdelt ) imassroute = 1
C
C5b------DETERMINE LAYER, ROW, COLUMN OF EACH REACH.
DO l = 1, NSTRM
lfold = l
IF ( Nfoldflbt==1 ) lfold = 1
gwflow = 0.0D0
dvrsn = 0.0D0
flowin = 0.0D0 !rsr, flowin may need a value
IF ( irt.EQ.1 ) THEN
SUMLEAK(l) = 0.0D0
SUMRCH(l) = 0.0
STRM(29,l) = 0.0
END IF
lsub = l
ll = l - 1
il = ISTRM(1, l)
ir = ISTRM(2, l)
ic = ISTRM(3, l)
C
C6------DETERMINE STREAM SEGMENT AND REACH NUMBER.
istsg = ISTRM(4, l)
nreach = ISTRM(5, l)
icalc = ISEG(1, istsg)
! RGN 5/9/09 set slope for all icalc
slope = STRM(2, l)
C
C7------SET FLOWIN EQUAL TO STREAM SEGMENT INFLOW IF FIRST REACH.
IF ( nreach.EQ.1 ) THEN
IF ( ISEG(3, istsg).EQ.5 ) flowin = SEG(2, istsg)
IF ( IDIVAR(1,istsg).EQ.0 )
+ sfrbudg_in = sfrbudg_in + SEG(2, istsg)
C
C8------STORE OUTFLOW FROM PREVIOUS SEGMENT IN SGOTFLW LIST AND IN
C STRIN FOR LAKE PACKAGE.
IF ( istsg.GT.1 ) THEN
iprvsg = ISTRM(4, ll)
SGOTFLW(iprvsg) = STRM(9, ll)
IF ( Iunitlak.GT.0 ) STRIN(iprvsg) = STRM(9, ll)
IF ( Iunitlak.GT.0 .AND. IDIVAR(1,istsg).LT.0 )
+ sfrbudg_out = sfrbudg_out + STRIN(iprvsg)
END IF
C
C9------COMPUTE INFLOW OF A STREAM SEGMENT EMANATING FROM A LAKE.
IF ( (Iunitlak.GT.0) .AND. (IDIVAR(1,istsg).LT.0) ) THEN
lk = IABS(IDIVAR(1, istsg))
IF ( SEG(2, istsg).GT.CLOSEZERO .AND.
+ VOL(lk).GT.CLOSEZERO ) THEN
IF( SEG(2, istsg)*DELT-VOL(lk).LT.-CLOSEZERO )THEN
FXLKOT(istsg) = SEG(2, istsg)
ELSE
FXLKOT(istsg) = VOL(lk)/DELT
END IF
flowin = FXLKOT(istsg)
sfrbudg_in = sfrbudg_in + FXLKOT(istsg)
ELSE IF ( SEG(2, istsg).LT.-CLOSEZERO ) THEN
WRITE (IOUT, 9001) istsg
9001 FORMAT (/5X, '*** WARNING *** NEGATIVE LAKE DIVERSION ',
+ 'NOT ALLOWED; SEG = ', I6, /10X,
+ 'SFR7BD CODE WILL ASSUME FLOW = 0.0'/)
SEG(2, istsg) = 0.0
FXLKOT(istsg) = SEG(2, istsg)
END IF
C
C10-----SPECIFIED FLOW FROM LAKE IS ZERO AND ICALC IS ZERO.
IF ( icalc.EQ.0 ) THEN
flowin = FXLKOT(istsg)
END IF
C
C11-----OUTFLOW FROM LAKE COMPUTED IN LAKE PACKAGE
IF ( FXLKOT(istsg).LE.CLOSEZERO ) THEN
flowin = STROUT(istsg)
sfrbudg_in = sfrbudg_in + flowin
END IF
END IF
C
C14-----COMPUTE ONE OR MORE DIVERSIONS FROM UPSTREAM SEGMENT.
Crgn&dep revised computation of diversions and added subroutine
IF( istsg.GT.1 )THEN
DO kss = 2, NSS
upflw = SGOTFLW(istsg-1)
idivseg = kss
IF( IDIVAR(1,kss).EQ.istsg-1 ) THEN
dvrsn = SEG(2,idivseg)
iprior = IDIVAR(2,kss)
CALL GWF2SFR7DIVERS(iprior, upflw, dvrsn)
DVRSFLW(kss) = dvrsn
SGOTFLW(istsg-1) = SGOTFLW(istsg-1) - dvrsn
END IF
END DO
C
C20-----SET FLOW INTO DIVERSION IF SEGMENT IS DIVERSION.
IF( ISEG(3,istsg).EQ.6 ) THEN
IF( IDIVAR(1,istsg).GT.0 ) flowin = DVRSFLW(istsg)
END IF
END IF
C
C22-----SUM TRIBUTARY OUTFLOW AND USE AS INFLOW INTO DOWNSTREAM SEGMENT.
IF ( istsg.GE.1 .AND. ISEG(3, istsg).EQ.7 ) THEN
itrib = 1
flowin = 0.0D0
DO WHILE ( itrib.LE.NSS )
IF ( istsg.EQ.IOTSG(itrib) ) THEN
trbflw = SGOTFLW(itrib)
flowin = flowin + trbflw
END IF
itrib = itrib + 1
END DO
flowin = flowin + SEG(2, istsg)
C
C23-----CHECK IF "FLOW" IS WITHDRAWAL, THAT WATER IS AVAILABLE.
IF ( flowin.LT.0.0D0 ) THEN
flowin = 0.0D0
! WRITE (IOUT, 9003) istsg
! 9003 FORMAT (//2X, '*** WARNING *** FLOW INTO DIVERSIONARY ',
! + 'STREAM SEGMENT No. ', I6, ' WAS NEGATIVE; ',
! + 'FLOWIN RE-SET = 0.0'/)
END IF
END IF
C
C24-----SET INFLOW EQUAL TO OUTFLOW FROM UPSTREAM REACH, WHEN REACH
C GREATER THAN 1.
ELSE IF ( nreach.GT.1 ) THEN
flowin = STRM(9, ll)
END IF
C
C25-----SEARCH FOR UPPER MOST ACTIVE CELL IN STREAM REACH. Revised ERB
ilay = il
TOPCELL: DO WHILE ( ilay.LE.NLAY )
IF ( IBOUND(ic, ir, ilay).EQ.0 ) THEN
ilay = ilay + 1
ELSE
EXIT TOPCELL
END IF
END DO TOPCELL
C
C26-----DETERMINE LEAKAGE THROUGH STREAMBED.
hstr = HSTRM(l,irt)
depth = hstr - STRM(3, l)
IF ( icalc.EQ.0 ) THEN
depth = STRM(15, l) - STRM(3, l)
hstr = STRM(15, l)
END IF
cstr = STRM(16, l)
width = HWDTH(l,irt)
sbot = STRM(4, l)
sbdthk = STRM(8, l)
strlen = STRM(1, l)
icalccheck = 0
totflwt = 0.0D0
totdelstor = 0.0D0
IF ( icalc.GE.2 ) wetperm = HWTPRM(l,irt)
IF ( IUZT.EQ.1 ) THEN
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) icalccheck = 1
IF ( icalccheck.EQ.1 ) THEN
fks = UHC(l)
thr = THTR(l)
epsilon = EPS(l)
thetas = THTS(l)
ha = -0.15
areamax = 0.0
fbcheck = 1.0D-12/DELT
IF ( fbcheck.LT.5.0D-8 ) fbcheck = 5.0D-8
avhc = STRM(6, l)
IF ( icalc.EQ.2 ) THEN
DO i = 1, ISUZN
UZSEEP(i, l) = 0.0D0
areamax = areamax + WETPER(i, l)*strlen
END DO
ELSE IF ( icalc.EQ.1 ) THEN
wetperm = width
WETPER(1, l) = width
UZSEEP(1, l) = 0.0D0
areamax = WETPER(1, l)*strlen
END IF
END IF
END IF
IF ( icalc.EQ.1 ) THEN
qcnst = CONST*width*SQRT(slope)/SEG(16, istsg)
ELSE IF ( icalc.EQ.3 ) THEN
awdth = SEG(14, istsg)
bwdth = SEG(15, istsg)
END IF
IF ( ilay.LE.NLAY ) il = ilay
C
C26b-----SET STREAMBED HYDRAULIC CONDUCTIVITY AND STREAM LEAKAGE TO
C ZERO WHEN NOT AN ACTIVE CELL.
IF ( IBOUND(ic, ir, il).LE.0 ) THEN
avhc = 0.0
! strleak = 0.0D0
h = hstr
END IF
IF ( ilay.LE.NLAY .AND. IBOUND(ic, ir, il).GT.0 ) THEN
C
C27-----COMPUTE HEAD DIFFERENCE ACROSS STREAMBED.
h = HNEW(ic, ir, il)
hld = HLDSFR(l)
! Added code to test for BCF or LPF 11/19/07
!rsr, modified as hld is double and hdry single
IF ( ABS(SNGL(hld)-HDRY).LT.CLOSEZERO ) hld = h
IF ( irt.EQ.numdelt ) HLDSFR(l) = h
IF ( h.LT.sbot ) THEN
hdiff = hstr - sbot
grad = (hdiff)/sbdthk
ELSE
hdiff = hstr - h
grad = (hdiff)/sbdthk
END IF
C
C28-----COMPUTE LEAKAGE ACROSS STREAMBED.
flobot = cstr*(hdiff)
C
C29-----STREAMFLOW OUT EQUALS STREAMFLOW IN MINUS LEAKAGE. Revised RSR
ELSE
flobot = 0.0D0
grad = 0.0D0
hdiff = 0.0D0
END IF
C
C30-----COMPUTE FLOW IN STREAM CHANNEL AND SET LEAKAGE EQUAL TO FLOW
C IF LEAKAGE MORE THAN FLOW. Revised DEP
runof = STRM(12, l)
runoff = STRM(24, l)
IF ( icalc.LE.1 ) THEN
precip = STRM(14, l)
etstr = STRM(13, l)
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
C
C31-----NO PRECIPITATION OR ET FROM CHANNEL WHEN WIDTH IS ZERO.
precip = STRM(14, l)*width
etstr = STRM(13, l)*width
END IF
flow = flowin + runof + runoff + precip - etstr
IF ( flow.LT.NEARZERO ) THEN
IF ( icalc.EQ.0 ) depth = 0.0D0
IF ( flobot.GE.0.0D0 ) THEN
flobot = 0.0D0
IF ( runof.LT.NEARZERO ) THEN
IF ( flowin+runoff+precip.LT.NEARZERO ) THEN
runof = 0.0D0
etstr = 0.0D0
ELSE IF (ABS(runof).GE.flowin+runoff+precip-etstr) THEN
runof = flowin + runoff + precip - etstr
ELSE IF ( etstr.GE.flowin+runoff+precip+runof ) THEN
etstr = flowin + runoff + precip + runof
END IF
ELSE IF ( flowin+runof+runoff+precip.GT.NEARZERO ) THEN
etstr = flowin + runof + runoff + precip
ELSE
etstr = 0.0D0
END IF
ELSE IF ( runof.LT.0.0D0 ) THEN
IF ( flowin+runoff+precip-flobot.LT.NEARZERO ) THEN
runof = 0.0D0
etstr = 0.0D0
ELSE IF (ABS(runof).GE.flowin+runoff+precip-flobot-etstr)
+ THEN
runof = -(flowin+runoff+precip-flobot-etstr)
ELSE IF (etstr.GE.flowin+runoff+precip-flobot+runof) THEN
etstr = flowin + runoff + precip - flobot + runof
END IF
ELSE IF ( etstr.GT.flowin+runoff+runof+precip-flobot ) THEN
etstr = flowin + runof + runoff + precip - flobot
ELSE IF ( flowin+runoff+runof+precip-flobot.LT.
+ NEARZERO ) THEN
etstr = 0.0D0
END IF
flow = flowin + runof + runoff + precip - etstr
END IF
IF ( flobot.GE.flow ) THEN
flobot = flow
IF ( icalc.EQ.0 ) depth = 0.0D0
END IF
! RGN Fixed statement. Only call subroutine if no UZ flow.
IF ( icalccheck.EQ.1 ) THEN
IF ( h.LT.sbot )
+ flobot = CALCUNSATFLOBOT(depth, avhc, fks, wetperm,
+ sbdthk, areamax, strlen, fbcheck,
+ NWAVST(:,l), maxwav, FOLDFLBT(lfold))
END IF
IF ( flobot.GE.flow ) flobot = flow
C
C32-----ROUTE FLOW IN CHANNELS WHEN IRTFLG IS NOT ZERO AND
C SIMULATION IS TRANSIENT.
IF ( IRTFLG.NE.0 .AND. iss.EQ.0 ) THEN
qlat = (runof + runoff + precip - etstr)/strlen
qa = STRM(26,l)
qb = STRM(25,l)
! RGN 6/10/09 set icalc 3 information
IF ( icalc.EQ.3 ) THEN
cdpth = SEG(9, istsg)
fdpth = SEG(10, istsg)
awdth = SEG(14, istsg)
bwdth = SEG(15, istsg)
END IF
IF ( ABS(TOTIM-DELT).LT.1.0E-10 ) qb = 0.0
IF ( ABS(TOTIM-DELT).LT.1.0E-10 ) qa = 0.0
qc = flowin
fltest = 0.0
IF ( flobot.LT.0.0D0 ) THEN
fltest=qa+qb+qc+qlat*strlen-flobot
ELSE
fltest=qa+qb+qc+qlat*strlen
END IF
IF ( fltest.GT.NEARZERO ) THEN
Transient_bd = 0.0
CALL ROUTE_CHAN(qa, qb, qc, qd, qcnst, cdpth, awdth,
+ fdpth, bwdth, deltinc, icalc, strlen, slope,
+ istsg, nreach, itstr, qlat, flobot, width, l,
+ Transient_bd)
STRM(30,l) = Transient_bd
Transient_bd_tot = Transient_bd_tot + Transient_bd
ELSE
qd = 0.0
END IF
flowot = qd
STRM(25,l) = qd
STRM(26,l) = qc
ELSE
flowot = flow - flobot
END IF
IF ( ISS.EQ.0 ) THEN
SUMLEAK(l) = SUMLEAK(l) + (flobot*deltinc)
IF ( irt.EQ.numdelt) SUMLEAK(l) = SUMLEAK(l)/DELT
ELSE
SUMLEAK(l) = flobot
END IF
IF ( icalccheck.EQ.1 .AND. irt.EQ.numdelt ) THEN
IF ( h.LT.sbot ) THEN
fbot = SUMLEAK(l)
CALL CALC_UNSAT_INFIL(fbot, UZSEEP(:,l),
+ UZTHST(:,l),thr, ha, thetas,
+ epsilon, fks, avhc,depth, sbdthk,
+ WETPER(:,l),UZWDTH(:,l), flow,
+ NWAVST(:,l),strlen, iwidthcheck,
+ icalc)
ELSE
DO i = 1, ISUZN
UZSEEP(i, l) = 0.0D0
END DO
END IF
END IF
C
C33-----STORE OUTFLOW FROM LAST REACH IN LAST SEGMENT IN STRIN
C LIST FOR LAKE PACKAGE.
IF ( Iunitlak.GT.0 ) THEN
IF ( l.EQ.NSTRM .AND. istsg.EQ.NSS ) STRIN(istsg) = flowot
END IF
C
C34-----STORE STREAM INFLOW, OUTFLOW, AND LEAKAGE FOR EACH REACH.
STRM(9, l) = flowot
STRM(10, l) = flowin
STRM(11, l) = flobot
STRM(17, l) = hdiff
STRM(18, l) = grad
STRM(19, l) = h
C
C35-----ADD FLOW TO STREAM BUDGET OUTFLOW IF FLOW LEAVES ACTIVE MODEL.
IF ( irt.EQ.numdelt ) THEN
IF ( l .LT. NSTRM ) THEN
IF ( IOTSG(istsg) .EQ. 0 .AND.
+ ISTRM(4, l) .NE. ISTRM(4, l+1)) THEN
sfrbudg_out = sfrbudg_out + flowot
END IF
ELSE IF( IOTSG(istsg) .EQ. 0 ) THEN
sfrbudg_out = sfrbudg_out + flowot
END IF
IF ( flobot .GT. 0.0D0 ) THEN
sfrbudg_out = sfrbudg_out + SUMLEAK(l)
ELSE
sfrbudg_in = sfrbudg_in - SUMLEAK(l)
END IF
sfrbudg_in = sfrbudg_in + precip
sfrbudg_in = sfrbudg_in + runof + runoff + flowin
sfrbudg_out = sfrbudg_out + etstr
END IF
C
C36-----STORE OUTFLOW FOR LAST SEGMENT IN SGOTFLW LIST AND IN STRIN FOR
C LAKE PACKAGE.
IF ( l.EQ.NSTRM ) THEN
SGOTFLW(istsg) = STRM(9, l)
IF ( Iunitlak.GT.0 ) STRIN(istsg) = STRM(9, l)
END IF
C
C37-----ADD RATES TO BUFFERS.
IF ( icalccheck.EQ.1 .AND. iss.EQ.0 ) THEN
IF ( irt.EQ.numdelt ) THEN
CALL UZMASSBAL(lsub, h, hld, thr, thetas, epsilon, fks,
+ UZDPST(:,l), UZTHST(:,l), UZSPST(:,l),
+ UZFLST(:,l), LTRLST(:,l), ITRLST(:,l),
+ UZFLWT(:,l), UZSTOR(:,l), DELSTOR(:,l),
+ NWAVST(:,l), UZOLSFLX(:,l), UZWDTH(:,l),
+ WETPER(:,l), UZSEEP(:,l), ratin, ratout, il,
+ ir, ic, flobot, sbot, strlen, totflwt,
+ totuzstor, totdelstor, iwidthcheck,
+ AVDPT(:,l), AVWAT(:,l), WAT1(:,l), ibd,
+ icalc, DELT, imassroute, Iunitgage,
+ gwflow)
END IF
FOLDFLBT(l) = flobot
ELSE
gwflow = flobot
BUFF(ic, ir, il) = BUFF(ic, ir, il) + flobot
IF ( IUZT.GT.0 ) totdelstor = 0.0D0
C
C38-----SUBTRACT FLOBOT FROM RATOUT WHEN GROUND WATER DISCHARGES
C TO STREAM REACH.
IF ( flobot.LT.0.0D0 ) THEN
ratout = ratout - flobot
SFRUZBD(9) = -flobot
END IF
C
C39-----ADD FLOBOT TO RATIN WHEN STREAM RECHARGES GROUND WATER.
IF ( flobot.GT.0.0D0 ) THEN
ratin = ratin + flobot
SFRUZBD(8) = flobot
END IF
IF ( icalccheck.EQ.1 .AND. sbot.GT.h ) THEN
totflwt = flobot*DELT
SFRUZBD(1) = SFRUZBD(1) + flobot*DELT
SFRUZBD(2) = 0.0
SFRUZBD(3) = SFRUZBD(3) + flobot*DELT
SFRUZBD(4) = SFRUZBD(4) + flobot
SFRUZBD(5) = 0.0
SFRUZBD(6) = SFRUZBD(6) + flobot
ELSE IF ( sbot.LT.h ) THEN
totflwt = 0.0
END IF
END IF
! write(iout,*)'bd',l,flobot
! write(iout,119)l,flowin,flowot,flobot
! 119 format(i5,3(1x,e20.10))
C
C40-----PRINT STREAMFLOWS AND RATES FOR EACH REACH TO MAIN LIST IF
C REQUESTED (ISTCB1<0 and IBD<0)AND NO UNSATURATED FLOW.
IF ( IUZT.EQ.0 ) THEN
IF ( ibd.LT.0 .AND. IPTFLG.LE.0 ) THEN
IF ( ibdlbl.EQ.0 ) WRITE (IOUT, 9004) txtlst, Kkper, Kkstp
WRITE (IOUT, 9005) il, ir, ic, ISTRM(4, l), ISTRM(5, l),
+ STRM(10, l), STRM(11, l), STRM(9, l),
+ SNGL(runof+runoff), SNGL(precip),
+ SNGL(etstr), STRM(15, l), SNGL(depth),
+ STRM(5, l), STRM(16, l), SNGL(grad)
ibdlbl = 1
END IF
C
C41-----PRINT STREAMFLOWS AND RATES FOR EACH REACH TO STREAM LIST
C IF REQUESTED (ISTCB2>0).
IF ( ibdst.LT.0 .AND. IPTFLG.LE.0 ) THEN
IF ( ibstlb.EQ.0 ) WRITE (iout2, 9004) txtlst, Kkper,
+ Kkstp
WRITE (iout2, 9005) il, ir, ic, ISTRM(4, l), ISTRM(5, l),
+ STRM(10, l), STRM(11, l), STRM(9, l),
+ SNGL(runof+runoff), SNGL(precip),
+ SNGL(etstr), STRM(15, l), SNGL(depth),
+ STRM(5, l), STRM(16, l), SNGL(grad)
ibstlb = 1
END IF
C
C42-----PRINT STREAMLFOWS AND RATES FOR EACH REACH TO MAIN LIST
C WHEN UNSATURATED FLOW IS ACTIVE.
ELSE
IF (ibd.LT.0 .AND. IPTFLG.LE.0 .AND. imassroute.EQ.1) THEN
IF ( ibdlbl.EQ.0 ) WRITE (IOUT, 9006) txtlst, Kkper, Kkstp
WRITE (IOUT, 9007) il, ir, ic, ISTRM(4,l), ISTRM(5,l),
+ STRM(10,l), STRM(11,l), STRM(9,l),
+ SNGL(runof+runoff), SNGL(precip),
+ SNGL(etstr), STRM(15,l), SNGL(depth),
+ STRM(5,l), STRM(16,l), totflwt/DELT,
+ totdelstor/DELT
ibdlbl = 1
END IF
C
C43-----PRINT STREAMFLOWS AND RATES FOR EACH REACH TO STREAM LIST
C WHEN UNSATRATED FLOW IS ACTIVE.
IF ( ibdst.LT.0 .AND. IPTFLG.LE.0 .AND.
+ imassroute.EQ.1 ) THEN
IF ( ISTCB2.EQ.IOUT ) THEN
IF ( ibstlb.EQ.0 ) WRITE (iout2, 9006) txtlst, Kkper,
+ Kkstp
WRITE (iout2, 9007) il, ir, ic, ISTRM(4,l), ISTRM(5,l),
+ STRM(10,l), STRM(11,l), STRM(9,l),
+ SNGL(runof+runoff), SNGL(precip),
+ SNGL(etstr), STRM(15,l), SNGL(depth),
+ STRM(5,l), STRM(16,l), totflwt/DELT,
+ totdelstor/DELT
ibstlb = 1
ELSE
IF ( ibstlb.EQ.0 ) WRITE (iout2, 9009) txtlst, Kkper,
+ Kkstp
WRITE (iout2, 9010) il, ir, ic, ISTRM(4,l), ISTRM(5,l),
+ STRM(10,l), STRM(11,l), STRM(9,l),
+ SNGL(runof+runoff), SNGL(precip),
+ SNGL(etstr), STRM(15,l), SNGL(depth),
+ STRM(5,l), STRM(16,l), totflwt/DELT,
+ totdelstor/DELT, SNGL(h)
ibstlb = 1
END IF
END IF
END IF
C
C44-----SAVE FLOW TO AND FROM GROUND WATER IN A LIST FILE WHEN
C IBD IS EQUAL TO 2. revised dep 5/10/2006--fixed 9/15/2006
cDEP need to fix for unsaturated flow
IF ( imassroute.EQ.1 .AND. ibd.EQ.2 )
+ CALL UBDSVA(iout1, NCOL, NROW, ic, ir, il,
+ SNGL(gwflow), IBOUND, NLAY)
END DO
! IF ( Irtflg.NE.0 )WRITE(IOUT,*)
! + 'TRANSIENT FLOW ERROR = ', Transient_bd
C
C45-----RECORD STREAM GAGING STATION DATA (IF SOLUTE TRANSPORT NOT ACTIVE).
IF ( Iunitgwt.LE.0 .AND. Iunitgage.GT.0 ) THEN
CALL SGWF2GAG7SO(Iunitgwt, Iunituzf, rtime, BUFF, SFRQ,
+ ibd, Nsol)
END IF
C
C46-----END OF INTERNAL TIME LOOP FOR ROUTING FLOW IN CHANNELS.
END DO
C
C46Bdep----New loop to compute specified flows from external sources
Cadded 6/27/2008
DO istsg = 1, NSS
IF ( ISEG(3, istsg).EQ.5 .OR. ISEG(3, istsg).EQ.7 ) THEN
TOTSPFLOW = TOTSPFLOW + SEG(2, istsg)
END IF
END DO
IF ( ibd.NE.0 .AND. IPTFLG.LE.0 ) WRITE (IOUT, 9008)
9004 FORMAT (1X, ///1X, A, ' PERIOD ', I6, ' STEP ', I8, //,
+ ' LAYER ROW COL. STREAM RCH. FLOW INTO ',
+ 'FLOW TO FLOW OUT OF OVRLND. DIRECT ',
+ 'STREAM STREAM STREAM STREAM ',
+ 'STREAMBED STREAMBED', /16X,
+ 'SEG.NO. NO. STRM. RCH. AQUIFER STRM. RCH.',
+ ' RUNOFF PRECIP ET HEAD ',
+ ' DEPTH WIDTH CONDCTNC. GRADIENT'/)
9005 FORMAT (1X, I3, I5, I5, 2I6, 3X, 1PE11.4, 1X, E11.4, 2X, E11.4,
+ 3(1X, E10.3), 1X, E12.5, 4(1X, E10.3))
Cdep revised format statement
9006 FORMAT (1X, ///1X, A, ' PERIOD ', I6, ' STEP ', I8, //,
+ ' LAYER ROW COL. STREAM RCH. FLOW INTO ',
+ ' STREAM FLOW OUT OF OVRLND. DIRECT ',
+ 'STREAM STREAM STREAM STREAM ',
+ 'STREAMBED FLOW TO CHNG. UNSAT. ', /16X,
+ 'SEG.NO. NO. STRM. RCH. LOSS ',
+ 'STRM. RCH. RUNOFF PRECIP ET ',
+ 'HEAD DEPTH WIDTH CONDCTNC. ',
+ 'WAT. TAB.', /)
9007 FORMAT (1X, I3, I5, I5, 2I6, 3X, 1PE11.4, 1X, E11.4, 2X, E11.4,
+ 3(1X, E10.3), 1X, E12.5, 5(1X, E10.3))
9008 FORMAT (//)
9009 FORMAT (1X, ///1X, A, ' PERIOD ', I6, ' STEP ', I8, //,
+ ' LAYER ROW COL. STREAM RCH. FLOW INTO ',
+ ' STREAM FLOW OUT OF OVRLND. DIRECT ',
+ 'STREAM STREAM STREAM STREAM ',
+ 'STREAMBED FLOW TO CHNG. UNSAT. GW ', /16X,
+ 'SEG.NO. NO. STRM. RCH. LOSS ',
+ 'STRM. RCH. RUNOFF PRECIP ET ',
+ 'HEAD DEPTH WIDTH CONDCTNC. ',
+ 'WAT. TAB. HEAD', /)
9010 FORMAT (1X, I3, I5, I5, 2I6, 3X, 1PE11.4, 1X, E11.4, 2X, E11.4,
+ 3(1X, E10.3), 1X, E12.5, 6(1X, E10.3))
C
C47-----PRINT MASS BALANCE OF UNSATURATED ZONE IF IUZT GREATER THAN 0.
IF ( IUZT.GT.0 .AND. ( ibd.NE.0 .OR. iblst.LT.0 ) )
+ CALL GWF2SFR7UZOT(Kkstp, Kkper)
C
C48-----SAVE FLOW TO AND FROM GROUND WATER AS A 3-D ARRAY WHEN
C IBD IS EQUAL TO 1. revised dep 5/10/2006
IF ( ibd.EQ.1 ) CALL UBUDSV(Kkstp, Kkper, text, iout1, BUFF, NCOL,
+ NROW, NLAY, IOUT)
C
C49-----MOVE RATES, VOLUMES, AND LABELS INTO ARRAYS FOR PRINTING.
rin = ratin
rout = ratout
VBVL(3, MSUM) = rin
VBVL(4, MSUM) = rout
VBVL(1, MSUM) = VBVL(1, MSUM) + rin*DELT
VBVL(2, MSUM) = VBVL(2, MSUM) + rout*DELT
VBNM(MSUM) = text
C
C50-----INCREMENT BUDGET TERM COUNTER.
MSUM = MSUM + 1
C
C51-----STREAMFLOW OUT OF EACH REACH IS SAVED TO A LIST FILE
C WHEN COMPACT BUDGET REQUESTED OR TO A 3-D ARRAY
C WHEN STANDARD UNFORMATTED BUDGET. revised dep 5/10/2006
IF ( ibdst.GT.0 ) THEN
DO il = 1, NLAY
DO ir = 1, NROW
DO ic = 1, NCOL
BUFF(ic, ir, il) = zero
END DO
END DO
END DO
DO l = 1, NSTRM
il = ISTRM(1, l)
ir = ISTRM(2, l)
ic = ISTRM(3, l)
ilay = il
BUFF(ic, ir, il) = BUFF(ic, ir, il) + STRM(9, l)
Cdep added compact budget option for streamflow out of reach
IF ( ibdst.EQ.2 ) CALL UBDSVA(iout2, NCOL, NROW, ic, ir,
+ il, STRM(9, l), IBOUND, NLAY)
END DO
IF ( ibdst.EQ.1 ) CALL UBUDSV(Kkstp, Kkper, strtxt, iout2,
+ BUFF, NCOL, NROW, NLAY, IOUT)
END IF
SFRRATIN = RATIN
SFRRATOUT = RATOUT
C
C52-----RETURN.
RETURN
END SUBROUTINE GWF2SFR7BD
C
C-------SUBROUTINE GWF2SFR7LAKOUTFLW
SUBROUTINE GWF2SFR7LAKOUTFLW(kkiter)
C *****************************************************************
C CALCULATE ARRAYS OF LAKE STAGE, FLOW, AND THE DERIVATIVE OF
C FLOWS FOR STREAM SEGMENTS THAT HAVE INFLOWS DETERMINED BY
C LAKE STAGE
C VERSION 7.1.01: February 15, 2009
C *****************************************************************
USE GWFSFRMODULE
IMPLICIT NONE
INTRINSIC FLOAT, ABS, IABS, DSQRT, DLOG10, SQRT, SNGL
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER icalc, istsg, l, lk, nreach, nstrpts, kkiter
REAL roughch, roughbnk, widthch
DOUBLE PRECISION finc, strbdtop, dlkstr1, dlkstr2, slope, cdpth,
+ fdpth, flwdlk1, flwdlk2, wdthlk1, wdthlk2,
+ wetperm1, wetperm2, width1, width2
C ------------------------------------------------------------------
C LOCAL STATIC VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION FIVE_THIRDS, DPMAXLK
PARAMETER (FIVE_THIRDS=5.0D0/3.0D0)
PARAMETER (DPMAXLK=10.0D0)
C
C1------LOOP THROUGH ALL STREAM REACHES.
C
DO l = 1, NSTRM
istsg = ISTRM(4, l)
nreach = ISTRM(5, l)
icalc = ISEG(1, istsg)
IF ( icalc.EQ.1 .OR. icalc.EQ.2 ) THEN
slope = STRM(2, l)
roughch = SEG(16, istsg)
IF ( icalc.EQ.1 )widthch = SEG(9, istsg)
IF ( icalc.EQ.2 )roughbnk = SEG(17, istsg)
END IF
IF ( icalc.EQ.4 ) nstrpts = ISEG(2, istsg)
C
C2------DETERMINE SEGMENTS THAT GET THEIR INFLOWS FROM A LAKE.
IF ( nreach.EQ.1 .AND. IDIVAR(1, istsg).LT.0 ) THEN
finc = DPMAXLK/200.0D0
strbdtop = SEG(8, istsg)
C
Cdep Added tables for computing lake outflow in Lake Package
C3------CALCUATE TABLES FOR LAKE STAGE AND CHANGE IN LAKE OUTFLOW.
DO lk = 1, 200
IF ( lk.EQ.1 )THEN
DLKSTAGE(1, istsg) = strbdtop
ELSE
DLKSTAGE(lk, istsg) = DLKSTAGE(lk-1, istsg) + finc
END IF
dlkstr1 = DLKSTAGE(lk, istsg)- strbdtop
dlkstr2 = dlkstr1 + 1.0D-07
C
C3------ICALC EQUALS 1.
IF ( icalc.EQ.1 ) THEN
flwdlk2 = (CONST/roughch)*widthch
+ *(dlkstr2**FIVE_THIRDS)*(DSQRT(slope))
DLKOTFLW(lk, istsg) = FIVE_THIRDS*flwdlk2/dlkstr2
SLKOTFLW(lk, istsg) = (CONST/roughch)*widthch
+ *(dlkstr1**FIVE_THIRDS)*(DSQRT(slope))
C
C4------ICALC EQUALS 2.
ELSE IF ( icalc.EQ.2 ) THEN
CALL GWF2SFR7FLW(dlkstr1, istsg, roughch,
+ roughbnk, slope, wetperm1,
+ flwdlk1, width1)
CALL GWF2SFR7FLW(dlkstr2, istsg, roughch,
+ roughbnk, slope, wetperm2,
+ flwdlk2, width2)
DLKOTFLW(lk, istsg) = (flwdlk1-flwdlk2)/(dlkstr1-dlkstr2)
SLKOTFLW(lk, istsg) = flwdlk1
c
C3-----ICALC EQUALS 3 USING FORMULA-- Q=(DEPTH/CDPTH)**1/FDPTH).
ELSE IF ( icalc.EQ.3 ) THEN
cdpth = SEG(9, istsg)
fdpth = SEG(10, istsg)
DLKOTFLW(lk, istsg) = (1.0D0/(cdpth*fdpth)) *
+ (dlkstr2/cdpth)**(1.0D0/fdpth-1.0D0)
SLKOTFLW(lk, istsg) = (dlkstr1/cdpth)**(1.0/fdpth)
C
C4-----FLOW FROM LAKE COMPUTED USING TABULATED VALUES.
ELSE IF ( icalc.EQ.4 ) THEN
CALL GWF2SFR7TBF(flwdlk1, dlkstr1, wdthlk1,
+ nstrpts, nreach, istsg, kkiter, 0)
CALL GWF2SFR7TBF(flwdlk2, dlkstr2, wdthlk2,
+ nstrpts, nreach, istsg, kkiter, 0)
DLKOTFLW(lk, istsg) = (flwdlk1-flwdlk2)/(dlkstr1-dlkstr2)
SLKOTFLW(lk, istsg) = flwdlk1
END IF
END DO
END IF
END DO
RETURN
END SUBROUTINE GWF2SFR7LAKOUTFLW
C
C-------SUBROUTINE GWF2SFR7DIVERS
SUBROUTINE GWF2SFR7DIVERS(Iprior, Upflw, Dvrsn)
C ******************************************************************
C COMPUTES DIVERSIONS FROM AN UPSTREAM SEGMENT
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
IMPLICIT NONE
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Iprior
DOUBLE PRECISION Upflw, Dvrsn
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION dif, prcnt
C ------------------------------------------------------------------
C1------IF IPRIOR IS ZERO THEN FLOW DIVERTED CAN BE ALL OF
C STREAMFLOW UP TO SPECIFIED FLOW.
IF ( Iprior.EQ.0 ) THEN
dif = Upflw - Dvrsn
IF ( dif.LT.0.0D0 ) THEN
Dvrsn = Upflw
END IF
C
C2------IF IPRIOR IS -1 THEN FLOW DIVERTED ONLY IF SPECIFIED FLOW
C AVAILABLE OTHERWISE NO FLOW DIVERTED.
ELSE IF ( Iprior.EQ.-1 ) THEN
dif = Upflw - Dvrsn
IF ( dif.LT.0.0D0 ) THEN
Dvrsn = 0.0D0
END IF
C
C3------IF IPRIOR IS -2 THEN FLOW DIVERTED IS PERCENTAGE OF
C AVAILABLE STREAMFLOW.
ELSE IF ( Iprior.EQ.-2 ) THEN
prcnt = Dvrsn
Dvrsn = Upflw*prcnt
C
C4------IF IPRIOR IS -3 THEN FLOW DIVERTED ONLY WHEN STREAMLFOW
C EXCEEDS SPECIFIED FLOW (FLOOD CONTROL DIVERSION).
ELSE IF ( Iprior.EQ.-3 ) THEN
IF ( Upflw.GT.Dvrsn ) THEN
Dvrsn = Upflw - Dvrsn
ELSE
Dvrsn = 0.0D0
END IF
END IF
RETURN
END SUBROUTINE GWF2SFR7DIVERS
C
C-------SUBROUTINE GWF2SFR7UZOT
SUBROUTINE GWF2SFR7UZOT(Kkstp, Kkper)
C ******************************************************************
C PRINTS MASS BALANCE FOR ENTIRE UNSATURATED ZONE
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: SFRUZBD, CLOSEZERO
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC ABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Kkper, Kkstp
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL adiffr, adiffv, bigvl1, bigvl2, diffr, diffv, prcntdifr,
+ prcntdifv, small, totrin, totrot, totvin, totvot
CHARACTER*17 text1, text2, text3
CHARACTER*18 val1, val2
C ------------------------------------------------------------------
text1 = ' STREAM LOSS'
text2 = 'CHANGE IN STORAGE'
text3 = ' RECHARGE TO GW'
bigvl1 = 9.99999E11
bigvl2 = 9.99999E10
small = 0.1
WRITE (IOUT, 9001) Kkstp, Kkper
WRITE (IOUT, 9002)
C
C1------PRINT INDIVIDUAL INFLOW RATES AND VOLUMES AND THEIR TOTALS.
C
C1a-----STREAM LEAKAGE.
IF ( ABS(SFRUZBD(1)).GT.CLOSEZERO .AND.
+ (SFRUZBD(1).GE.bigvl1 .OR. SFRUZBD(1).LT.small) ) THEN
WRITE (val1, '(1PE18.4)') SFRUZBD(1)
ELSE
WRITE (val1, '(F18.4)') SFRUZBD(1)
END IF
IF ( ABS(SFRUZBD(4)).GT.CLOSEZERO .AND.
+ (SFRUZBD(4).GE.bigvl1 .OR. SFRUZBD(4).LT.small) ) THEN
WRITE (val2, '(1PE18.4)') SFRUZBD(4)
ELSE
WRITE (val2, '(F18.4)') SFRUZBD(4)
END IF
WRITE (IOUT, 9003) text1, val1, text1, val2
C
C1b-----CHANGE IN STORAGE.
IF ( ABS(SFRUZBD(2)).GT.CLOSEZERO .AND.
+ (ABS(SFRUZBD(2)).GE.bigvl1 .OR.
+ ABS(SFRUZBD(2)).LT.small) ) THEN
WRITE (val1, '(1PE18.4)') SFRUZBD(2)
ELSE
WRITE (val1, '(F18.4)') SFRUZBD(2)
END IF
IF ( ABS(SFRUZBD(5)).GT.CLOSEZERO .AND.
+ (ABS(SFRUZBD(5)).GE.bigvl1 .OR.
+ ABS(SFRUZBD(5)).LT.small) ) THEN
WRITE (val2, '(1PE18.4)') SFRUZBD(5)
ELSE
WRITE (val2, '(F18.4)') SFRUZBD(5)
END IF
WRITE (IOUT, 9003) text2, val1, text2, val2
C
C1c-----RECHARGE.
IF ( ABS(SFRUZBD(3)).GT.CLOSEZERO .AND.
+ (SFRUZBD(3).GE.bigvl1 .OR. SFRUZBD(3).LT.small) ) THEN
WRITE (val1, '(1PE18.4)') SFRUZBD(3)
ELSE
WRITE (val1, '(F18.4)') SFRUZBD(3)
END IF
IF ( ABS(SFRUZBD(6)).GT.CLOSEZERO .AND.
+ (SFRUZBD(6).GE.bigvl1 .OR. SFRUZBD(6).LT.small) ) THEN
WRITE (val2, '(1PE18.4)') SFRUZBD(6)
ELSE
WRITE (val2, '(F18.4)') SFRUZBD(6)
END IF
WRITE (IOUT, 9003) text3, val1, text3, val2
C
C2------SUM INFLOWS AND OUTFLOWS.
IF ( SFRUZBD(2).GT.0.0 ) THEN
totvin = SFRUZBD(1)
totvot = SFRUZBD(3) + SFRUZBD(2)
ELSE
totvin = SFRUZBD(1) - SFRUZBD(2)
totvot = SFRUZBD(3)
END IF
IF ( SFRUZBD(5).GT.0.0 ) THEN
totrin = SFRUZBD(4)
totrot = SFRUZBD(6) + SFRUZBD(5)
ELSE
totrin = SFRUZBD(4) - SFRUZBD(5)
totrot = SFRUZBD(6)
END IF
IF ( ABS(totrin+totrot).GT.CLOSEZERO ) THEN
prcntdifr = 100.*(totrin-totrot)/(totrin+totrot)/2.0
ELSE
prcntdifr = 0.0
END IF
IF ( ABS(totvin+totvot).GT.CLOSEZERO ) THEN
prcntdifv = 100.*(totvin-totvot)/(totvin+totvot)/2.0
ELSE
prcntdifv = 0.0
END IF
C
C3------PRINT TOTALS AND RATES TO GROUND WATER.
IF ( ABS(totvin).GT.CLOSEZERO .AND. (totvin.GE.bigvl1 .OR.
+ totvin.LT.small) ) THEN
WRITE (val1, '(1PE18.4)') totvin
ELSE
WRITE (val1, '(F18.4)') totvin
END IF
IF ( ABS(totrin).GT.CLOSEZERO .AND. (totrin.GE.bigvl1 .OR.
+ totrin.LT.small) ) THEN
WRITE (val2, '(1PE18.4)') totrin
ELSE
WRITE (val2, '(F18.4)') totrin
END IF
WRITE (IOUT, 9004) val1, val2
C
C4------PRINT TOTALS AND RATES FROM GROUND WATER.
IF ( ABS(totvot).GT.CLOSEZERO .AND. (totvot.GE.bigvl1 .OR.
+ totvot.LT.small) ) THEN
WRITE (val1, '(1PE18.4)') totvot
ELSE
WRITE (val1, '(F18.4)') totvot
END IF
IF ( ABS(totrot).GT.CLOSEZERO .AND. (totrot.GE.bigvl1 .OR.
+ totrot.LT.small) ) THEN
WRITE (val2, '(1PE18.4)') totrot
ELSE
WRITE (val2, '(F18.4)') totrot
END IF
WRITE (IOUT, 9006) val1, val2
C
C5------PRINT DIFFERENCES AND PERCENT DIFFERENCES BETWEEN INPUT
C AND OUTPUT RATES AND VOLUMES.
diffv = totvin - totvot
adiffv = ABS(diffv)
IF ( ABS(adiffv).GT.CLOSEZERO .AND. (adiffv.GE.bigvl2 .OR.
+ adiffv.LT.small) ) THEN
WRITE (val1, '(1PE18.4)') diffv
ELSE
WRITE (val1, '(F18.4)') diffv
END IF
diffr = totrin - totrot
adiffr = ABS(diffr)
IF ( ABS(adiffr).GT.CLOSEZERO .AND. (adiffr.GE.bigvl2 .OR.
+ adiffr.LT.small) ) THEN
WRITE (val2, '(1PE18.4)') diffr
ELSE
WRITE (val2, '(F18.4)') diffr
END IF
WRITE (IOUT, 9007) val1, val2
WRITE (IOUT, 9008) prcntdifv, prcntdifr
C
9001 FORMAT ('1', /2X,
+ 'VOLUMETRIC BUDGET FOR UNSATURATED ZONE BENEATH ',
+ 'STREAMS AT END OF TIME STEP', I4, ' STRESS PERIOD',
+ I4/2X, 96('-'))
9002 FORMAT (1X, /4X, 'CUMULATIVE VOLUMES', 13X, 'L**3', 4X,
+ 'RATES FOR THIS TIME STEP', 9X, 'L**3/T'/4X, 18('-'),
+ 21X, 24('-')//11X)
9003 FORMAT (1X, 2X, A18, ' =', A18, 5X, A18, ' =', A18)
9004 FORMAT (1X, /13X, 'TOTAL IN =', A, 15X, 'TOTAL IN =', A)
9006 FORMAT (1X, /12X, 'TOTAL OUT =', A, 14X, 'TOTAL OUT =', A)
9007 FORMAT (1X, /13X, 'IN - OUT =', A, 15X, 'IN - OUT =', A)
9008 FORMAT (1X, /1X, ' PERCENT DISCREPANCY =', 1X, F15.2, 5X,
+ ' PERCENT DISCREPANCY =', 2X, F15.2, ///)
C
C6------RETURN.
RETURN
END SUBROUTINE GWF2SFR7UZOT
C
C-------SUBROUTINE GWF2SFR7DPTH
SUBROUTINE GWF2SFR7DPTH(Flow, Slope, Istsg, Nreach, Roughch,
+ Roughbnk, Wetperm, Depth, Itstr, Totwdth,
+ Iprndpth)
C ******************************************************************
C COMPUTE STREAM DEPTH GIVEN FLOW USING 8-POINT CROSS SECTION
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: CONST, XSEC, NEARZERO
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC DMIN1, SQRT, DABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Roughbnk, Roughch
INTEGER Iprndpth, Istsg, Itstr, Nreach
DOUBLE PRECISION Flow, Slope, Wetperm, Depth, Totwdth
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER i, iflg
DOUBLE PRECISION flow1, flow2, flow3, y0, ymin, xnum, dnom, stage,
+ depth1, depth2, depth3, f1, f2, f3, err1, err2,
+ err3
C ------------------------------------------------------------------
C
C1------INITIALIZE VARIABLES TO ZERO.
Totwdth = 0.0D0
Wetperm = 0.0D0
C
C2------FIND LOWEST POINT IN CHANNEL.
ymin = XSEC(9, Istsg)
DO i = 9, 16
y0 = XSEC(i, Istsg)
ymin = DMIN1(ymin, y0)
END DO
C
C3------ESTIMATE INITIAL DEPTH ASSUMING WIDE RECTANGULAR CHANNEL.
depth1 = 0.0D0
xnum = Flow*Roughch
dnom = CONST*(XSEC(6, Istsg)-XSEC(3, Istsg))*SQRT(Slope)
IF ( dnom.GT.0.0 ) depth1 = (xnum/dnom)**0.6D0
IF ( depth1.GT.0.0D0 ) THEN
stage = depth1 + ymin
flow1 = 0.0D0
CALL GWF2SFR7FLW(stage, Istsg, Roughch, Roughbnk, Slope,
+ Wetperm, flow1, Totwdth)
f1 = Flow - flow1
depth2 = 1.1D0*depth1
stage = depth2 + ymin
flow2 = 0.0D0
CALL GWF2SFR7FLW(stage, Istsg, Roughch, Roughbnk, Slope,
+ Wetperm, flow2, Totwdth)
f2 = Flow - flow2
C
C4------ESTIMATE NEW DEPTH USING EITHER BISECTION OR SECANT METHOD
C FOR SOLVING ROOTS.
depth3 = 0.0D0
IF ( (f1*f2).LT.0.0D0 .AND.
+ ((depth1.GT.2.D0*depth2) .OR. (depth2.GT.(2.D0*depth1))) )
+ THEN
C
C5------USE BISECTION METHOD.
depth3 = (depth1+depth2)*0.5D0
C
C6------USE SECANT METHOD.
ELSE
depth3 = depth2 - (f2*(depth2-depth1)/(f2-f1))
END IF
err1 = DABS(depth3-depth1)
err2 = DABS(depth3-depth2)
IF ( err1.LT.0.000001 .AND. err2.LT.0.000001 ) THEN
depth3 = (depth1+depth2)*0.5D0
C
C7------CONTINUE RECALCULATING DEPTH3 UNTIL ERROR LESS THAN 0.000001
C OR 100 ITERATIONS HAVE BEEN REACHED.
ELSE
iflg = 1
Itstr = 1
DO WHILE ( iflg.GT.0 )
IF ( f1*f2.LT.0.0D0 .AND.
+ (depth1.GT.2.0D0*depth2 .OR. depth2.GT.2.0D0*depth1) )
+ THEN
depth3 = (depth1+depth2)*0.5D0
ELSE IF ( DABS(f2-f1).GT.0.0D0 ) THEN
depth3 = depth2 - (f2*(depth2-depth1)/(f2-f1))
ELSE IF ( DABS(f2-f1).LT.NEARZERO ) THEN
depth3 = (depth1+depth2)*0.5D0
END IF
err1 = DABS(depth3-depth1)
err2 = DABS(depth3-depth2)
err3 = DABS(f2-f1)
IF ( (err1.LT.0.000001 .OR. err2.LT.0.000001) .AND.
+ Itstr.GT.2 ) iflg = 0
IF ( err3.LT.0.0001 .AND. Itstr.GT.2 ) iflg = 0
stage = depth3 + ymin
CALL GWF2SFR7FLW(stage, Istsg, Roughch, Roughbnk, Slope,
+ Wetperm, flow3, Totwdth)
f3 = Flow - flow3
IF ( f2*f3.LT.0.0D0 ) THEN
C
C8------ROOT IS BETWEEN DEPTH2 AND DEPTH3.
IF ( f1*f2.LT.0.0D0 ) THEN
C
C9------ROOT IS BETWEEN DEPTH1 AND DEPTH2.
depth1 = depth3
f1 = f3
ELSE
C
C10-----DEPTH1 AND DEPTH2 ON SAME SIDE OF ROOT;
C REPLACE WITH FARTHER ROOT.
IF ( DABS(f1).GT.DABS(f2) ) THEN
depth1 = depth2
f1 = f2
END IF
depth2 = depth3
f2 = f3
END IF
C
C11-----DEPTH2 AND DEPTH3 ARE ON THE SAME SIDE OF ROOT.
ELSE IF ( f1*f2.LT.0.0D0 ) THEN
C
C12-----ROOT IS BETWEEN DEPTH1 AND DEPTH2.
depth2 = depth3
f2 = f3
ELSE
C
C13-----DEPTH1,DEPTH2, AND DEPTH3 ARE ON SAME SIDE OF ROOT;
C REPLACE WITH NEAREST VALUE.
IF ( DABS(f1).GT.DABS(f2) ) THEN
depth1 = depth2
f1 = f2
END IF
depth2 = depth3
f2 = f3
END IF
Itstr = Itstr + 1
IF ( Iprndpth.EQ.1 ) THEN
WRITE (IOUT, 9001) Itstr, iflg, Flow, depth1, depth2,
+ depth3, f1, f2, f3
9001 FORMAT (1X/, 'ITSTR,IFLG,FLOW,DEPTH1,DEPTH2,DEPTH3,F1,F2,'
+ , ',F3 ', 2I5, 7(2X, D15.6))
END IF
C
C14-----PRINT WARNING MESSAGE IF SECANT METHOD FAILED TO FIND A DEPTH.
IF ( Itstr.GT.100 ) THEN
iflg = 0
WRITE (IOUT, 9002) Istsg, Nreach, depth3, depth1, depth2
9002 FORMAT (1X/, 'SECANT METHOD FAILED TO FIND SOLUTION FOR',
+ ' STREAM SEGMENT ', I5, ' REACH ', I5,
+ 'ESTIMATED DEPTH IS ', D15.6, 'AND BOUNDS ARE ',
+ 2(2X, D15.6))
END IF
END DO
END IF
C
C15-----CALCULATE WETTED PERIMETER AND WIDTH FROM FINAL DEPTH.
Depth = depth3
stage = Depth + ymin
flow1 = Flow
CALL GWF2SFR7FLW(stage, Istsg, Roughch, Roughbnk, Slope,
+ Wetperm, flow1, Totwdth)
ELSE
Depth = 0.0D0
Wetperm = 0.0D0
Totwdth = 0.0D0
Itstr = 0
END IF
C
C16-----RETURN.
RETURN
END SUBROUTINE GWF2SFR7DPTH
C
C-------SUBROUTINE GWF2SFR7FLW
SUBROUTINE GWF2SFR7FLW(Depth, Istsg, Roughch, Roughbnk, Slope,
+ Wetperm, Flow, Totwdth)
C *******************************************************************
C COMPUTE FLOW IN STREAM GIVEN DEPTH USING 8-POINT CROSS SECTION
C VERSION 7.1.01: February 15, 2009
C *******************************************************************
USE GWFSFRMODULE, ONLY: XSEC, CONST
IMPLICIT NONE
INTRINSIC DABS, DSQRT
C -------------------------------------------------------------------
C SPECIFICATIONS:
C -------------------------------------------------------------------
C ARGUMENTS
C -------------------------------------------------------------------
REAL Roughbnk, Roughch
INTEGER Istsg
DOUBLE PRECISION Flow, Wetperm, Totwdth, Depth, Slope
C -------------------------------------------------------------------
C LOCAL VARIABLES
C -------------------------------------------------------------------
REAL fac, r, rough, subarea, wtprm
INTEGER i, ii, j
DOUBLE PRECISION xleft, yleft, dpthleft, dpthrght, xright, yright,
+ x0, y0, x1, y1, wtprm1, wtprm2, wtprm3, width1,
+ width2, width3, width, subarea1, subarea2,
+ subarea3, subflow1, subflow2, subflow3
C -------------------------------------------------------------------
C
C1------INITIALIZE VARIABLES TO ZERO.
Totwdth = 0.0D0
Wetperm = 0.0D0
subarea1 = 0.0D0
subarea2 = 0.0D0
subarea3 = 0.0D0
subflow1 = 0.0D0
subflow2 = 0.0D0
subflow3 = 0.0D0
wtprm1 = 0.0D0
wtprm2 = 0.0D0
wtprm3 = 0.0D0
width1 = 0.0D0
width2 = 0.0D0
width3 = 0.0D0
fac = 2./3.
j = 1
C
C2------INITIALIZE X AND Y POINTS; START AT I = 2.
DO i = 2, 8
ii = i + 8
x0 = XSEC(i-1, Istsg)
y0 = XSEC(ii-1, Istsg)
x1 = XSEC(i, Istsg)
y1 = XSEC(ii, Istsg)
IF ( Depth.GT.y0 ) THEN
C
C3------LEFT ENDPOINT IS SUBMERGED.
xleft = x0
yleft = y0
dpthleft = Depth - yleft
IF ( Depth.GT.y1 ) THEN
C
C4------LEFT AND RIGHT ENDPOINTS ARE SUBMERGED.
xright = x1
yright = y1
dpthrght = Depth - yright
ELSE
C
C5------LEFT ENDPOINT IS SUBMERGED AND RIGHT IS NOT.
dpthrght = 0.0D0
yright = Depth
xright = x0 + (x1-x0)*(yright-y0)/(y1-y0)
END IF
width = DABS(xright-xleft)
ELSE IF ( Depth.GT.y1 ) THEN
C
C6------LEFT ENDPOINT IS ABOVE WATER AND RIGHT IS SUBMERGED.
dpthleft = 0.0D0
yleft = Depth
xleft = x1 - (x1-x0)*(y1-yleft)/(y1-y0)
xright = x1
yright = y1
dpthrght = Depth - yright
width = DABS(xright-xleft)
ELSE
C
C7------LEFT AND RIGHT ENDPOINTS ARE ABOVE WATER.
dpthleft = 0.0D0
dpthrght = 0.0D0
width = 0.0D0
END IF
C
C8------ADD AREA AND WETPERM FOR SUBSECTION OF CHANNEL.
IF ( dpthleft+dpthrght.GT.0.0 ) THEN
subarea = 0.5D0*(dpthleft+dpthrght)*width
wtprm = DSQRT(((xleft-xright)*(xleft-xright))
+ +((yleft-yright)*(yleft-yright)))
IF ( j.EQ.1 ) THEN
subarea1 = subarea1 + subarea
wtprm1 = wtprm1 + wtprm
width1 = width1 + width
END IF
IF ( j.EQ.2 ) THEN
subarea2 = subarea2 + subarea
wtprm2 = wtprm2 + wtprm
width2 = width2 + width
END IF
IF ( j.EQ.3 ) THEN
subarea3 = subarea3 + subarea
wtprm3 = wtprm3 + wtprm
width3 = width3 + width
END IF
END IF
C
C9------COMPUTE FLOW FOR EACH SUBSECTION OF CHANNEL.
IF ( i.EQ.3 .OR. i.EQ.6 .OR. i.EQ.8 ) THEN
IF ( j.EQ.2 ) THEN
rough = Roughch
ELSE
rough = Roughbnk
END IF
IF ( j.EQ.1 .AND. wtprm1.GT.0.0 ) THEN
r = (subarea1/wtprm1)**fac
subflow1 = (CONST/rough)*subarea1*r*(Slope)**0.5D0
ELSE IF ( j.EQ.2 .AND. wtprm2.GT.0.0 ) THEN
r = (subarea2/wtprm2)**fac
subflow2 = (CONST/rough)*subarea2*r*(Slope)**0.5D0
ELSE IF ( j.EQ.3 .AND. wtprm3.GT.0.0 ) THEN
r = (subarea3/wtprm3)**fac
subflow3 = (CONST/rough)*subarea3*r*(Slope)**0.5D0
END IF
j = j + 1
END IF
END DO
C
C10-----SUM FLOW, WETTED PERIMETER, AND WIDTH FOR SUBSECTIONS.
Flow = subflow1 + subflow2 + subflow3
Totwdth = width1 + width2 + width3
Wetperm = wtprm1 + wtprm2 + wtprm3
C
C11-----RETURN.
RETURN
END SUBROUTINE GWF2SFR7FLW
C
C-------SUBROUTINE GWF2SFR7TBD
SUBROUTINE GWF2SFR7TBD(Flow, Depth, Width, Nstrpts, Istsg)
C *******************************************************************
C COMPUTE DEPTH AND WIDTH IN STREAM GIVEN FLOW USING RATING TABLES.
C VERSION 7.1.01: February 15, 2009
C *******************************************************************
USE GWFSFRMODULE, ONLY: QSTAGE
IMPLICIT NONE
INTRINSIC DLOG10
C -------------------------------------------------------------------
C SPECIFICATIONS:
C -------------------------------------------------------------------
C ARGUMENTS
C -------------------------------------------------------------------
INTEGER Istsg, Nstrpts
DOUBLE PRECISION Flow, Depth, Width
C -------------------------------------------------------------------
C LOCAL VARIABLES
C -------------------------------------------------------------------
INTEGER iflwlw, istghi, istglw, istp, iwthhi, iwthlw
DOUBLE PRECISION flwlw, flwhi, stglw, stghi, wthlw, wthhi, dflwlw,
+ dflwhi, dstglw, dstghi, dwthlw, dwthhi, dlgflw,
+ dlgsls, dlgslw, dlgstg, dlgwth
C -------------------------------------------------------------------
C
C1------DEFINE RANGE OF FLOW, DEPTH, AND WIDTH FROM RATING TABLE.
flwlw = QSTAGE(1, Istsg)
stglw = QSTAGE(1+Nstrpts, Istsg)
wthlw = QSTAGE(1+(2*Nstrpts), Istsg)
flwhi = QSTAGE(Nstrpts, Istsg)
stghi = QSTAGE(2*Nstrpts, Istsg)
wthhi = QSTAGE(3*Nstrpts, Istsg)
C
C2------USE A LINEAR INTERPOLATION TO ESTIMATE DEPTH AND WIDTH WHEN
C FLOW IS LESS THAN LOWEST VALUE IN TABLE.
IF ( Flow.LE.flwlw ) THEN
Depth = (stglw/flwlw)*Flow
Width = (wthlw/flwlw)*Flow
C
C3------OTHERWISE USE A LOG INTERPOLATION TO ESTIMATE DEPTH AND WIDTH.
ELSE IF ( Flow.GT.flwlw ) THEN
C
C4------FIND NEAREST VALUES OF FLOW, DEPTH, AND WIDTH IN TABLE.
istp = 2
flwhi = QSTAGE(istp, Istsg)
DO WHILE ( Flow.GT.flwhi .AND. istp.LT.Nstrpts )
istp = istp + 1
flwhi = QSTAGE(istp, Istsg)
END DO
IF ( Flow.LE.flwhi ) THEN
istghi = istp + Nstrpts
istglw = istghi - 1
iwthhi = istp + (2*Nstrpts)
iwthlw = iwthhi - 1
iflwlw = istp - 1
stghi = QSTAGE(istghi, Istsg)
stglw = QSTAGE(istglw, Istsg)
wthhi = QSTAGE(iwthhi, Istsg)
wthlw = QSTAGE(iwthlw, Istsg)
flwlw = QSTAGE(iflwlw, Istsg)
ELSE IF ( Flow.GT.flwhi ) THEN
C
C5------COMPUTED FLOW EXCEEDS HIGHEST FLOW IN TABLE.
flwlw = QSTAGE(Nstrpts-1, Istsg)
stglw = QSTAGE((2*Nstrpts)-1, Istsg)
stghi = QSTAGE(2*Nstrpts, Istsg)
wthlw = QSTAGE((3*Nstrpts)-1, Istsg)
wthhi = QSTAGE((3*Nstrpts), Istsg)
END IF
C
C6------COMPUTE DEPTH AND WIDTH FROM LOG INTERPOLATION.
dstglw = DLOG10(stglw)
dstghi = DLOG10(stghi)
dwthlw = DLOG10(wthlw)
dwthhi = DLOG10(wthhi)
dflwlw = DLOG10(flwlw)
dflwhi = DLOG10(flwhi)
dlgflw = DLOG10(Flow) - dflwlw
dlgsls = (dstghi-dstglw)/(dflwhi-dflwlw)
dlgslw = (dwthhi-dwthlw)/(dflwhi-dflwlw)
dlgstg = dstglw + (dlgsls*dlgflw)
dlgwth = dwthlw + (dlgslw*dlgflw)
Depth = 10.D0**dlgstg
Width = 10.D0**dlgwth
END IF
C
C7------RETURN.
RETURN
END SUBROUTINE GWF2SFR7TBD
C
C-------SUBROUTINE GWF2SFR7TBF
SUBROUTINE GWF2SFR7TBF(Flow, Depth, Width, Nstrpts, Nreach, Istsg,
+ Kkiter, Itb)
C *******************************************************************
C COMPUTE FLOW AND WIDTH IN STREAM GIVEN DEPTH USING RATING TABLES.
C VERSION 7.1.01: February 15, 2009
C *******************************************************************
USE GWFSFRMODULE, ONLY: QSTAGE
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC DLOG10
C -------------------------------------------------------------------
C SPECIFICATIONS:
C -------------------------------------------------------------------
C ARGUMENTS
C -------------------------------------------------------------------
INTEGER Istsg, Itb, Kkiter, Nreach, Nstrpts
DOUBLE PRECISION Flow, Depth, Width
C -------------------------------------------------------------------
C LOCAL VARIABLES
C -------------------------------------------------------------------
INTEGER iflwhi, iflwlw, istglw, istp, iwthhi, iwthlw
DOUBLE PRECISION flwlw, flwhi, stglw, stghi, wthlw, wthhi, dflwlw,
+ dflwhi, dstglw, dstghi, dwthlw, dwthhi, dlgflw,
+ dlgslf, dlgslw, dlgstg, dlgwth
C -------------------------------------------------------------------
C
C1------DEFINE RANGE OF FLOW, DEPTH, AND WIDTH FROM RATING TABLE.
flwlw = QSTAGE(1, Istsg)
stglw = QSTAGE(1+Nstrpts, Istsg)
wthlw = QSTAGE(1+(2*Nstrpts), Istsg)
flwhi = QSTAGE(Nstrpts, Istsg)
stghi = QSTAGE(2*Nstrpts, Istsg)
wthhi = QSTAGE(3*Nstrpts, Istsg)
C
C2------USE A LINEAR INTERPOLATION TO ESTIMATE FLOW AND WIDTH WHEN
C DEPTH IS LESS THAN LOWEST VALUE IN TABLE.
IF ( Depth.LE.stglw ) THEN
Flow = (flwlw/stglw)*Depth
Width = (wthlw/flwlw)*Flow
C
C3------OTHERWISE USE A LOG INTERPOLATION TO ESTIMATE FLOW AND WIDTH.
ELSE IF ( Depth.GT.stglw ) THEN
istp = 2
stghi = QSTAGE(istp+Nstrpts, Istsg)
C
C4------FIND NEAREST VALUES OF FLOW, DEPTH, AND WIDTH IN TABLE.
DO WHILE ( Depth.GT.stghi .AND. istp.LT.Nstrpts )
istp = istp + 1
stghi = QSTAGE(istp+Nstrpts, Istsg)
END DO
IF ( Depth.LE.stghi ) THEN
istglw = (istp-1) + Nstrpts
iflwhi = istp
iflwlw = istp - 1
iwthhi = istp + (2*Nstrpts)
iwthlw = iwthhi - 1
stglw = QSTAGE(istglw, Istsg)
wthhi = QSTAGE(iwthhi, Istsg)
wthlw = QSTAGE(iwthlw, Istsg)
flwlw = QSTAGE(iflwlw, Istsg)
flwhi = QSTAGE(iflwhi, Istsg)
ELSE IF ( Depth.GT.stghi .AND. Itb.EQ.1 ) THEN
C
C5------PRINT WARNING IF COMPUTED DEPTH EXCEEDS HIGHEST DEPTH IN TABLE.
WRITE (IOUT, 9001) Kkiter, Istsg, Nreach, Depth, stghi
9001 FORMAT (1X/, 'FOR MODFLOW ITERATION ', I5,
+ ' DEPTH IN SEGMENT ', I5, ' REACH ', I5, ' IS ',
+ 1PE10.3, ' AND IS GREATER THAN ',
+ 'HIGHEST DEPTH LISTED IN RATING TABLE OF ', 1PE10.3,
+ //1X, 'ASSUMING SAME RELATION AS ',
+ 'BETWEEN TWO HIGHEST DEPTHS IN TABLE'//)
flwlw = QSTAGE(Nstrpts-1, Istsg)
stglw = QSTAGE((2*Nstrpts)-1, Istsg)
stghi = QSTAGE(2*Nstrpts, Istsg)
wthlw = QSTAGE((3*Nstrpts)-1, Istsg)
wthhi = QSTAGE((3*Nstrpts), Istsg)
flwlw = QSTAGE(Nstrpts-1, Istsg)
flwhi = QSTAGE(Nstrpts, Istsg)
stglw = QSTAGE((2*Nstrpts)-1, Istsg)
stghi = QSTAGE((2*Nstrpts), Istsg)
wthlw = QSTAGE((3*Nstrpts)-1, Istsg)
wthhi = QSTAGE((3*Nstrpts), Istsg)
END IF
C
C6------COMPUTE DEPTH AND WIDTH FROM LOG INTERPOLATION.
dstglw = DLOG10(stglw)
dstghi = DLOG10(stghi)
dwthlw = DLOG10(wthlw)
dwthhi = DLOG10(wthhi)
dflwlw = DLOG10(flwlw)
dflwhi = DLOG10(flwhi)
dlgstg = DLOG10(Depth) - dstglw
dlgslf = (dflwhi-dflwlw)/(dstghi-dstglw)
dlgslw = (dwthhi-dwthlw)/(dstghi-dstglw)
dlgflw = dflwlw + (dlgslf*dlgstg)
dlgwth = dwthlw + (dlgslw*dlgstg)
Flow = 10.D0**dlgflw
Width = 10.D0**dlgwth
END IF
C
C7------RETURN.
RETURN
END SUBROUTINE GWF2SFR7TBF
C
C-------SUBROUTINE SGWF2SFR7RDSEG
SUBROUTINE SGWF2SFR7RDSEG(Nlst, Lstbeg, In, Iunitgwt, Ischk,
+ Nischk, Ichk, Kkper, Nsol)
C ******************************************************************
C READ STREAM SEGMENT DATA -- parameters or non parameters
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NSS, MAXPTS, ISFROPT, IDIVAR, IOTSG, ISEG,
+ SEG, XSEC, QSTAGE, CONCQ, CONCRUN, CONCPPT
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Iunitgwt, Ichk, In, Ischk, Lstbeg, Nischk, Nlst, Kkper
INTEGER Nsol
DIMENSION Ischk(Nischk)
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER icalc, idum, ii, iqseg, isol, iupseg, jj, jk, lstend, n,
+ noutseg, nseg, nstrpts
C ------------------------------------------------------------------
C
C1------READ STREAM SEGMENT DATA.
lstend = Lstbeg + Nlst - 1
DO iqseg = Lstbeg, lstend
C
C2------ONLY READ FIRST 4 VARIABLES TO DETERMINE VALUE OF IUPSEG.
READ (In, *) n, icalc, noutseg, iupseg
IF ( n.GT.NSS .OR. n.LT.1 ) THEN
WRITE (IOUT, 9001) n
9001 FORMAT (1X, /1X, 'SEGMENT NUMBER (NSEG) OUT OF RANGE: ', I6)
IF ( Ichk.NE.0 ) THEN
WRITE (IOUT, 9002) iqseg - Lstbeg + 1
9002 FORMAT (1X, 'READING ENTRY ', I6, ' OF ITEM 6A')
ELSE
WRITE (IOUT, 9003) iqseg - Lstbeg + 1
9003 FORMAT (1X, 'READING ENTRY ', I6, ' OF ITEM 4A')
END IF
CALL USTOP(' ')
END IF
C
C3------DETERMINE WHERE DATA ARE STORED.
IF ( Ichk.NE.0 ) THEN
C Store data in active segment area
nseg = n
Ischk(n) = Ischk(n) + 1
ELSE
C Store data in parameter area
nseg = iqseg
ISEG(3, iqseg) = n
SEG(1, nseg) = SEG(1, n)
END IF
BACKSPACE In
C
C4------READ DATA SET 4B FOR SEGMENTS THAT ARE NOT DIVERSIONS.
IF ( iupseg.LE.0 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ IDIVAR(1, nseg), (SEG(jj, nseg), jj=2, 5)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ IDIVAR(1, nseg), (SEG(jj, nseg), jj=2, 5),
+ SEG(16, nseg)
ELSE IF ( icalc.EQ.2 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ IDIVAR(1, nseg), (SEG(jj, nseg), jj=2, 5),
+ (SEG(jk, nseg), jk=16, 17)
ELSE IF ( icalc.EQ.3 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ IDIVAR(1, nseg), (SEG(jj, nseg), jj=2, 5),
+ SEG(9, nseg), SEG(10, nseg), SEG(14, nseg),
+ SEG(15, nseg)
ELSE IF ( icalc.EQ.4 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ IDIVAR(1, nseg), ISEG(2, nseg),
+ (SEG(jj, nseg), jj=2, 5)
END IF
C
C5------READ DATA 4B FOR SEGMENTS THAT ARE DIVERSIONS FROM STREAMS.
ELSE IF ( icalc.LE.0 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ (IDIVAR(ii, nseg), ii=1, 2),
+ (SEG(jj, nseg), jj=2, 5)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ (IDIVAR(ii, nseg), ii=1, 2),
+ (SEG(jj, nseg), jj=2, 5), SEG(16, nseg)
ELSE IF ( icalc.EQ.2 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ (IDIVAR(ii, nseg), ii=1, 2),
+ (SEG(jj, nseg), jj=2, 5),
+ (SEG(jk, nseg), jk=16, 17)
ELSE IF ( icalc.EQ.3 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ (IDIVAR(ii, nseg), ii=1, 2),
+ (SEG(jj, nseg), jj=2, 5), SEG(9, nseg),
+ SEG(10, nseg), SEG(14, nseg), SEG(15, nseg)
ELSE IF ( icalc.EQ.4 ) THEN
READ (In, *) idum, ISEG(1, nseg), IOTSG(nseg),
+ (IDIVAR(ii, nseg), ii=1, 2), ISEG(2, nseg),
+ (SEG(jj, nseg), jj=2, 5)
END IF
C
C6------READ DATA SET 4C.
IF ( ISFROPT.EQ.0 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 10)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 9)
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 8)
END IF
ELSE IF ( ISFROPT.EQ.1 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) SEG(9, nseg), SEG(10, nseg)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) SEG(9, nseg)
END IF
ELSE IF ( ISFROPT.EQ.2 .OR. ISFROPT.EQ.3 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) SEG(9, nseg), SEG(10, nseg)
ELSE IF ( icalc.EQ.1 .AND. Kkper.EQ.1 ) THEN
READ (In, *) SEG(9, nseg)
END IF
ELSE IF ( ISFROPT.EQ.4 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 10)
ELSE IF ( icalc.EQ.1 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 9),
+ (SEG(jj, nseg), jj=18, 20)
ELSE
READ (In, *) SEG(6, nseg)
END IF
ELSE IF ( icalc.EQ.2 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 8),
+ (SEG(jj, nseg), jj=18, 20)
ELSE
READ (In, *) SEG(6, nseg)
END IF
ELSE IF ( icalc.GE.3 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 8)
END IF
ELSE IF ( ISFROPT.EQ.5 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 10)
ELSE IF ( icalc.EQ.1 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 9),
+ (SEG(jj, nseg), jj=18, 21)
ELSE
READ (In, *) SEG(6, nseg)
END IF
ELSE IF ( icalc.EQ.2 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 8),
+ (SEG(jj, nseg), jj=18, 21)
ELSE
READ (In, *) SEG(6, nseg)
END IF
ELSE IF ( icalc.GE.3 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=6, 8)
END IF
END IF
C
C7------READ DATA SET 4D.
IF ( ISFROPT.EQ.0 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 15)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 14)
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 13)
END IF
ELSE IF ( ISFROPT.EQ.1 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) SEG(14, nseg), SEG(15, nseg)
ELSE IF ( icalc.EQ.1 ) THEN
READ (In, *) SEG(14, nseg)
END IF
ELSE IF ( ISFROPT.EQ.2 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) SEG(14, nseg), SEG(15, nseg)
ELSE IF ( icalc.EQ.1 .AND. Kkper.EQ.1 ) THEN
READ (In, *) SEG(14, nseg)
END IF
ELSE IF ( ISFROPT.EQ.3 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) SEG(14, nseg), SEG(15, nseg)
ELSE IF ( icalc.EQ.1 .AND. Kkper.EQ.1 ) THEN
READ (In, *) SEG(14, nseg)
END IF
ELSE IF ( ISFROPT.EQ.4 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 15)
ELSE IF ( icalc.EQ.1 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 14),
+ (SEG(jj, nseg), jj=22, 24)
ELSE
READ (In, *) SEG(11, nseg)
END IF
ELSE IF ( icalc.EQ.2 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 13),
+ (SEG(jj, nseg), jj=22, 24)
ELSE
READ (In, *) SEG(11, nseg)
END IF
ELSE IF ( icalc.GE.3 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 13)
END IF
ELSE IF ( ISFROPT.EQ.5 ) THEN
IF ( icalc.LE.0 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 15)
ELSE IF ( icalc.EQ.1 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 14),
+ (SEG(jj, nseg), jj=22, 25)
ELSE
READ (In, *) SEG(11, nseg)
END IF
ELSE IF ( icalc.EQ.2 ) THEN
IF ( Kkper.EQ.1 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 13),
+ (SEG(jj, nseg), jj=22, 25)
ELSE
READ (In, *) SEG(11, nseg)
END IF
ELSE IF ( icalc.GE.3 .AND. icalc.LE.4 ) THEN
READ (In, *) (SEG(jj, nseg), jj=11, 13)
END IF
END IF
C
C8------READ DATA SET 4E FOR SEGMENT WHEN ICALC IS 2.
IF ( icalc.EQ.2 ) THEN
C ADDED CONDITIONAL IF WHEN UNSATURATED FLOW INACTIVE DEP
IF ( Kkper.EQ.1 .OR. ISFROPT.LE.1 ) THEN
READ (In, *) (XSEC(jj, nseg), jj=1, 8)
READ (In, *) (XSEC(jj, nseg), jj=9, 16)
END IF
END IF
C
C9------READ DATA SET 4F FOR SEGMENT WHEN ICALC IS 4.
IF ( icalc.EQ.4 ) THEN
nstrpts = ISEG(2, nseg)
IF ( nstrpts.LT.2 ) THEN
WRITE (IOUT, 9004) n
9004 FORMAT (/1X, 'NUMBER OF POINTS USED TO RELATE ',
+ 'STREAMFLOW WITH STREAM DEPTH AND WIDTH FOR ',
+ 'SEGMENT ', I6, ' IS LESS THAN TWO'//1X,
+ 'PROGRAM STOPPING')
CALL USTOP(' ')
ELSE IF ( nstrpts.GT.MAXPTS/3 ) THEN
WRITE (IOUT, 9005) n, nstrpts
9005 FORMAT (/1X, 'FOR SEGMENT ', I6, ' NUMBER OF POINTS',
+ 'USED TO RELATE STREAMFLOW WITH DEPTH AND ',
+ 'WIDTH IS ', I5//1X, 'WHICH IS MORE THAN ',
+ 'MAXIMUM NUMBER OF 50 POINTS', //1X,
+ 'PROGRAM STOPPING'//)
CALL USTOP(' ')
ELSE
READ (In, *) (QSTAGE(jj, nseg), jj=1, nstrpts)
READ (In, *) (QSTAGE(jj, nseg), jj=nstrpts+1, 2*nstrpts)
READ (In, *) (QSTAGE(jj, nseg), jj=2*nstrpts+1, 3*nstrpts)
END IF
END IF
C
C10-----READ DATA SET 4G FOR SEGMENT IF SOLUTES SPECIFIED.
IF ( Iunitgwt.GT.0 ) THEN
DO isol = 1, Nsol
IF ( IDIVAR(1, nseg).EQ.0 ) THEN
READ (In, *) CONCQ(nseg, isol), CONCRUN(nseg, isol),
+ CONCPPT(nseg, isol)
ELSE
READ (In, *) CONCRUN(nseg, isol), CONCPPT(nseg, isol)
END IF
END DO
END IF
C
END DO
C
C11-----RETURN.
RETURN
END SUBROUTINE SGWF2SFR7RDSEG
C
C-------SUBROUTINE SGWF2SFR7PARMOV
SUBROUTINE SGWF2SFR7PARMOV(In, Iunitgwt, Nsol)
C ******************************************************************
C MOVE STREAM PARAMETER DATA INTO ACTIVE SEGMENTS
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: IDIVAR, IOTSG, ISEG, SEG, XSEC, QSTAGE,
+ CONCQ, CONCRUN, CONCPPT, NSEGCK
USE GLOBAL, ONLY: IOUT
USE PARAMMODULE, ONLY: IACTIVE, IPLOC, PARNAM, INAME, B
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER In, Iunitgwt, Nsol
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL rdum
INTEGER icalc, idum, iloc, ip, iqseg, isol, istart, istop, iupseg,
+ jend, jj, ki, lloc, lstend, ni, nlst, nseg, nstrpts,
+ numinst, lstbeg
CHARACTER*4 package
CHARACTER*200 line
CHARACTER*10 pname, ctmp3, ctmp4
C ------------------------------------------------------------------
C
package = 'SFR '
C
C1------READ PARAMETER NAME AND FIND IT IN THE PARAMETER LIST.
READ (In, '(A)') line
lloc = 1
CALL URWORD(line, lloc, istart, istop, 0, idum, rdum, IOUT, In)
pname = line(istart:istop)
WRITE (IOUT, 9001) pname
9001 FORMAT (/, ' Parameter: ', A)
CALL UPARFIND(pname, 'SFR', 'SFR', ip, IOUT)
C
C2------DESIGNATE CELLS CORRESPONDING TO CORRECT PARAMETER INSTANCE.
nlst = IPLOC(2, ip) - IPLOC(1, ip) + 1
numinst = IPLOC(3, ip)
iloc = IPLOC(4, ip)
ni = 1
IF ( numinst.GT.0 ) THEN
nlst = nlst/numinst
CALL URWORD(line, lloc, istart, istop, 0, idum, rdum, IOUT, In)
ctmp3 = line(istart:istop)
IF ( ctmp3.EQ.' ' ) THEN
WRITE (IOUT, 9002) package, PARNAM(ip)
9002 FORMAT (/, 1X, 'Blank instance name in the ', A,
+ ' file for parameter ', A)
CALL USTOP(' ')
END IF
WRITE (IOUT, 9003) ctmp3
9003 FORMAT (3X, 'Instance: ', A)
CALL UPCASE(ctmp3)
DO ki = 1, numinst
ctmp4 = INAME(iloc+ki-1)
CALL UPCASE(ctmp4)
IF ( ctmp3.EQ.ctmp4 ) THEN
ni = ki
GOTO 100
END IF
END DO
WRITE (IOUT, 9004) package, ctmp3, PARNAM(ip)
9004 FORMAT (/, 1X, 'The ', A,
+ ' file specifies undefined instance "', A,
+ '" for parameter ', A)
CALL USTOP(' ')
END IF
C
100 IF ( IACTIVE(ip).GT.0 ) THEN
WRITE (IOUT, 9005) PARNAM(ip)
9005 FORMAT (/, 1X, '*** ERROR: PARAMETER "', A,
+ '" HAS ALREADY BEEN ACTIVATED THIS STRESS PERIOD', /,
+ ' -- STOP EXECUTION (SGWF2SFR7PARMOV)')
CALL USTOP(' ')
END IF
C
IACTIVE(ip) = ni
C
C3------MOVE EACH ENTRY FOR THE PARAMETER.
lstbeg = IPLOC(1, ip) + (ni-1)*nlst
C changed iqseg to lstbeg in the following line. 4/25/06
lstend = lstbeg + nlst - 1
DO iqseg = lstbeg, lstend
C
C4------DETERMINE VALUES OF ICALC, NSEG, AND IUPSEG.
icalc = ISEG(1, iqseg)
nseg = ISEG(3, iqseg)
iupseg = IDIVAR(1, iqseg)
C
C5------COUNT THE NUMBER OF TIMES A SEGMENT IS DEFINED.
NSEGCK(nseg) = NSEGCK(nseg) + 1
C
C6------MOVE DATA SET 4A.
ISEG(1, nseg) = ISEG(1, iqseg)
IOTSG(nseg) = IOTSG(iqseg)
IDIVAR(1, nseg) = IDIVAR(1, iqseg)
IF ( iupseg.GT.0 ) IDIVAR(2, nseg) = IDIVAR(2, iqseg)
SEG(2, nseg) = SEG(2, iqseg)
SEG(3, nseg) = SEG(3, iqseg)
SEG(4, nseg) = SEG(4, iqseg)
SEG(5, nseg) = SEG(5, iqseg)
IF ( icalc.EQ.1 ) THEN
SEG(16, nseg) = SEG(16, iqseg)
ELSE IF ( icalc.EQ.2 ) THEN
SEG(16, nseg) = SEG(16, iqseg)
SEG(17, nseg) = SEG(17, iqseg)
ELSE IF ( icalc.EQ.3 ) THEN
SEG(9, nseg) = SEG(9, iqseg)
SEG(10, nseg) = SEG(10, iqseg)
SEG(14, nseg) = SEG(14, iqseg)
SEG(15, nseg) = SEG(15, iqseg)
ELSE IF ( icalc.EQ.4 ) THEN
ISEG(2, nseg) = ISEG(2, iqseg)
END IF
C
C7------MOVE DATA SET 4B.
IF ( icalc.LE.0 ) THEN
jend = 10
ELSE IF ( icalc.EQ.1 ) THEN
jend = 9
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
jend = 8
END IF
DO jj = 6, jend
SEG(jj, nseg) = SEG(jj, iqseg)
END DO
SEG(6, nseg) = SEG(6, nseg)*B(ip)
C
C8------MOVE DATA SET 4C.
IF ( icalc.LE.0 ) THEN
jend = 15
ELSE IF ( icalc.EQ.1 ) THEN
jend = 14
ELSE IF ( icalc.GE.2 .AND. icalc.LE.4 ) THEN
jend = 13
END IF
DO jj = 11, jend
SEG(jj, nseg) = SEG(jj, iqseg)
END DO
SEG(11, nseg) = SEG(11, nseg)*B(ip)
C
C9------MOVE DATA SET 4D FOR SEGMENT WHEN ICALC IS 2.
IF ( icalc.EQ.2 ) THEN
DO jj = 1, 16
XSEC(jj, nseg) = XSEC(jj, iqseg)
END DO
END IF
C
C10-----MOVE DATA SET 4E FOR SEGMENT WHEN ICALC IS 4.
IF ( icalc.EQ.4 ) THEN
nstrpts = ISEG(2, nseg)
DO jj = 1, nstrpts*3
QSTAGE(jj, nseg) = QSTAGE(jj, iqseg)
END DO
END IF
C
C11-----MOVE DATA SET 4F FOR SEGMENT IF SOLUTES SPECIFIED.
IF ( Iunitgwt.GT.0 ) THEN
DO isol = 1, Nsol
IF ( IDIVAR(1, nseg).EQ.0 ) THEN
CONCQ(nseg, isol) = CONCQ(iqseg, isol)
CONCRUN(nseg, isol) = CONCRUN(iqseg, isol)
CONCPPT(nseg, isol) = CONCPPT(iqseg, isol)
ELSE
CONCRUN(nseg, isol) = CONCRUN(iqseg, isol)
CONCPPT(nseg, isol) = CONCPPT(iqseg, isol)
END IF
END DO
END IF
C
END DO
C12-----RETURN.
RETURN
END SUBROUTINE SGWF2SFR7PARMOV
C
C-------SUBROUTINE SGWF2SFR7PRSEG
SUBROUTINE SGWF2SFR7PRSEG(Nlst, Lstbeg, Iunitgwt, Kkper, Nsol,
+ Iouts)
C ******************************************************************
C PRINT STREAM SEGMENT DATA -- parameters or non parameters
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: ISFROPT, IDIVAR, IOTSG, ISEG, SEG, XSEC,
+ QSTAGE, CONCQ, CONCRUN, CONCPPT
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Nlst, Lstbeg, Iunitgwt, Kkper, Nsol, Iouts
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER i, icalc, iflg, ii, ipt, isol, jj, lstend, nn, nseg,
+ nstrpts
C ------------------------------------------------------------------
C
lstend = Nlst + Lstbeg - 1
WRITE (IOUT, 9001)
9001 FORMAT (1X, //20X, 'INPUT DATA FOR EACH STREAM SEGMENT', /1X,
+ 93('-')/)
C
C1------PRINT INPUT FLOW RATES FOR EACH STREAM SEGMENT.
WRITE (IOUT, 9002)
9002 FORMAT (1X, 'SEGMENT SEG. INFLOW OVERLAND ',
+ 'STREAM STREAM ICALC OUTFLOW DIVERSION PRIORITY',
+ /4X, 'NO. LENGTH RATE RUNOFF ',
+ 'ET PPT. METH. TO SEG. FROM SEG. NO.'/)
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
WRITE (IOUT, 9003) nn, (SEG(ii, nseg), ii=1, 5), ISEG(1, nseg),
+ IOTSG(nseg), (IDIVAR(jj, nseg), jj=1, 2)
9003 FORMAT (1X, I6, 1X, 1P5E10.3, 2X, I3, 3X, I6, 3X, I6, 4X, I5)
END DO
C
C2------PRINT STREAMBED PROPERTIES AND STREAM DIMENSIONS.
IF ( Lstbeg.EQ.1 ) THEN
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9004)
ELSE IF ( ISFROPT.GT.0 .AND. ISFROPT.LT.4 ) THEN
WRITE (IOUT, 9005)
ELSE IF ( ISFROPT.EQ.4 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9006)
ELSE
WRITE (IOUT, 9004)
END IF
ELSE IF ( ISFROPT.EQ.5 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9008)
ELSE
WRITE (IOUT, 9004)
END IF
END IF
c rgn added else and write statement.
ELSE
WRITE(IOUT,210)
210 FORMAT (1X,//9X,'STREAMBED PROPERTIES AND STREAM ',
1 'DIMENSIONS',//1X,'SEGMENT BED HYD. COND. FACTOR',2X,
2 'BED THICKNESS ELEV.-TOP OF BED WIDTH OF ',
3 'STREAM DEPTH OF STREAM STREAM ROUGHNESS',/1X,
4 ' No. UPPER LOWER UPPER ',
5 'LOWER UPPER LOWER UPPER LOWER ',
6 'UPPER LOWER CHANNEL BANK'/)
END IF
9004 FORMAT (1X, //9X, 'STREAMBED PROPERTIES AND STREAM DIMENSIONS', //
+ ' SEGMENT BED HYD. COND.', 6X,
+ 'BED THICKNESS ELEV.-TOP OF BED WIDTH OF ',
+ 'STREAM DEPTH OF STREAM STREAM ROUGHNESS', /,
+ ' No. UPPER LOWER UPPER ',
+ 'LOWER UPPER LOWER UPPER LOWER ',
+ 'UPPER LOWER CHANNEL BANK'/)
9005 FORMAT (1X, //9X, 'STREAMBED PROPERTIES AND STREAM DIMENSIONS', //
+ ' SEGMENT WIDTH OF STREAM', 5X,
+ 'DEPTH OF STREAM STREAM ROUGHNESS', /,
+ ' No. UPPER LOWER UPPER ',
+ 'LOWER CHANNEL BANK'/)
9006 FORMAT (1X, //9X, 'STREAMBED PROPERTIES AND STREAM DIMENSIONS', //
+ ' SEGMENT BED HYD. COND.', 6X,
+ 'BED THICKNESS ELEV.-TOP OF BED WIDTH OF ',
+ 'STREAM DEPTH OF STREAM STREAM ROUGHNESS ',
+ ' SAT. WATER CONT. INT. WATER CONT. BROOKS/',
+ 'COREY EPS.'/,
+ ' No. UPPER LOWER UPPER ',
+ 'LOWER UPPER LOWER UPPER LOWER ',
+ 'UPPER LOWER CHANNEL BANK UPPER ',
+ 'LOWER UPPER LOWER UPPER LOWER'/)
9008 FORMAT (1X, //9X, 'STREAMBED PROPERTIES AND STREAM DIMENSIONS', //
+ ' SEGMENT BED HYD. COND.', 6X,
+ 'BED THICKNESS ELEV.-TOP OF BED WIDTH OF ',
+ 'STREAM DEPTH OF STREAM STREAM ROUGHNESS ',
+ ' SAT. WATER CONT. INT. WATER CONT. BROOKS/',
+ 'COREY EPS. UNSAT. HYD. COND.', /,
+ ' No. UPPER LOWER UPPER ',
+ 'LOWER UPPER LOWER UPPER LOWER ',
+ 'UPPER LOWER CHANNEL BANK UPPER ',
+ 'LOWER UPPER LOWER UPPER LOWER ',
+ 'UPPER'/)
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
icalc = ISEG(1, nseg)
IF ( icalc.EQ.0 ) THEN
IF ( ISFROPT.EQ.0 .OR. ISFROPT.GT.3 ) THEN
WRITE (IOUT, 9010) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg), SEG(8, nseg)
+ , SEG(13, nseg), SEG(9, nseg),
+ SEG(14, nseg), SEG(10, nseg),
+ SEG(15, nseg)
9010 FORMAT (I6, 1X, 1P10E10.3)
ELSE
WRITE (IOUT, 9011) nn, SEG(9, nseg), SEG(14, nseg),
+ SEG(10, nseg), SEG(15, nseg)
9011 FORMAT (I6, 1X, 1P4E10.3)
END IF
ELSE IF ( icalc.EQ.1 ) THEN
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9012) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg), SEG(8, nseg)
+ , SEG(13, nseg), SEG(9, nseg),
+ SEG(14, nseg), SEG(16, nseg)
9012 FORMAT (I6, 1X, 1P8E10.3, 20X, 1PE10.3)
! RGN changed next line to "ISFROPT.GE.1" instead of "ISFROPT.GT.1"
ELSE IF ( ISFROPT.GE.1 .AND. ISFROPT.LT.4 ) THEN
WRITE (IOUT, 9013) nn, SEG(9, nseg), SEG(14, nseg),
+ SEG(16, nseg)
9013 FORMAT (I6, 3X, 1P2E10.3, 21X, 1PE10.3)
ELSE IF ( ISFROPT.EQ.4 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9014) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg),
+ SEG(8, nseg), SEG(13, nseg),
+ SEG(9, nseg), SEG(14, nseg),
+ SEG(16, nseg), SEG(18, nseg),
+ SEG(22, nseg), SEG(19, nseg),
+ SEG(23, nseg), SEG(20, nseg),
+ SEG(24, nseg)
9014 FORMAT (I6, 1X, 1P8E10.3, 20X, 1PE10.3, 10X, 1P6E10.3)
ELSE
WRITE (IOUT, 9015) nn, SEG(6, nseg), SEG(11, nseg)
9015 FORMAT (I6, 1X, 1P2E10.3)
END IF
ELSE IF ( ISFROPT.EQ.5 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9016) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg),
+ SEG(8, nseg), SEG(13, nseg),
+ SEG(9, nseg), SEG(14, nseg),
+ SEG(16, nseg), SEG(18, nseg),
+ SEG(22, nseg), SEG(19, nseg),
+ SEG(23, nseg), SEG(20, nseg),
+ SEG(24, nseg), SEG(21, nseg),
+ SEG(25, nseg)
9016 FORMAT (I6, 1X, 1P8E10.3, 20X, 1PE10.3, 10X, 1P8E10.3)
ELSE
WRITE (IOUT, 9017) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(16, nseg)
9017 FORMAT (I6, 1X, 1P2E10.3, 60X, 1PE10.3)
END IF
END IF
ELSE IF ( icalc.EQ.2 ) THEN
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9018) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg), SEG(8, nseg)
+ , SEG(13, nseg), SEG(16, nseg),
+ SEG(17, nseg)
9018 FORMAT (I6, 1X, 1P6E10.3, 40X, 1P2E10.3)
ELSE IF ( ISFROPT.EQ.4 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9020) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg),
+ SEG(8, nseg), SEG(13, nseg),
+ SEG(16, nseg), SEG(17, nseg),
+ SEG(18, nseg), SEG(22, nseg),
+ SEG(19, nseg), SEG(23, nseg),
+ SEG(20, nseg), SEG(24, nseg)
9020 FORMAT (I6, 1X, 1P6E10.3, 40X, 1P8E10.3)
ELSE
WRITE (IOUT, 9021) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(16, nseg), SEG(17, nseg)
9021 FORMAT (I6, 1X, 1P2E10.3, 80X, 1P2E10.3)
END IF
ELSE IF ( ISFROPT.EQ.5 ) THEN
IF ( Kkper.EQ.1 ) THEN
WRITE (IOUT, 9022) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg),
+ SEG(8, nseg), SEG(13, nseg),
+ SEG(16, nseg), SEG(17, nseg),
+ SEG(18, nseg), SEG(22, nseg),
+ SEG(19, nseg), SEG(23, nseg),
+ SEG(20, nseg), SEG(24, nseg),
+ SEG(21, nseg), SEG(25, nseg)
9022 FORMAT (I6, 1X, 1P6E10.3, 40X, 1P10E10.3)
ELSE
WRITE (IOUT, 9023) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(16, nseg), SEG(17, nseg)
9023 FORMAT (I6, 1X, 1P2E10.3, 80X, 1P2E10.3)
END IF
END IF
ELSE IF ( icalc.GE.3 ) THEN
IF ( ISFROPT.EQ.0 ) THEN
WRITE (IOUT, 9024) nn, SEG(6, nseg), SEG(11, nseg),
+ SEG(7, nseg), SEG(12, nseg), SEG(8, nseg)
+ , SEG(13, nseg)
9024 FORMAT (I6, 1X, 1P6E10.3)
END IF
END IF
END DO
C
C4------PRINT CROSS-SECTIONAL DATA FOR SEGMENTS WITH ICALC=2.
iflg = 0
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
icalc = ISEG(1, nseg)
IF ( icalc.EQ.2 .AND. iflg.EQ.0 ) THEN
WRITE (IOUT, 9025)
9025 FORMAT (1X, /1X, ' EIGHT POINT CROSS-SECTION DATA ',
+ 'FOR SEGMENTS WITH ICALC = 2', /3X, ' X VALUES',
+ ' X VALUES START FROM LEFT SIDE LOOKING ',
+ 'DOWNSTREAM', //5X, 'SEGMENT NO.',
+ ' X1 X2 X3 X4',
+ ' X5 X6 X7 X8')
iflg = 1
END IF
IF ( icalc.EQ.2 .AND. iflg.EQ.1 ) THEN
WRITE (IOUT, 9026) nn, (XSEC(i, nseg), i=1, 8)
9026 FORMAT (7X, I6, 5X, 8(1PE10.3))
END IF
END DO
iflg = 0
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
icalc = ISEG(1, nseg)
IF ( icalc.EQ.2 .AND. iflg.EQ.0 ) THEN
WRITE (IOUT, 9027)
9027 FORMAT (1X, /3X, ' Z VALUES ARE RELATIVE TO STREAM',
+ 'BED ELEVATION', //5X, 'SEGMENT NO. ',
+ 'Z1 Z2 Z3 Z4 Z5',
+ ' Z6 Z7 Z8')
iflg = 1
END IF
IF ( icalc.EQ.2 .AND. iflg.EQ.1 ) THEN
WRITE (IOUT, 9028) nn, (XSEC(i, nseg), i=9, 16)
9028 FORMAT (7X, I6, 5X, 8(1PE10.3))
END IF
END DO
C
C5------PRINT STREAMFLOW, DEPTH AND WIDTH RELATIONS FOR SEGMENTS
C WITH ICALC=3.
iflg = 0
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
icalc = ISEG(1, nseg)
IF ( icalc.EQ.3 .AND. iflg.EQ.0 ) THEN
WRITE (IOUT, 9029)
9029 FORMAT (/1X, 'STREAMFLOW RELATION WITH DEPTH IS ',
+ 'BASED ON EQUATION Q = CDPTH*(DEPTH)**FDPTH', /1X,
+ 'STREAMFLOW RELATION WITH WIDTH IS ',
+ 'BASED ON EQUATION Q = AWDTH*(WIDTH)**BWDTH', //1X,
+ 'SEGMENT NO. CDPTH FDPTH ',
+ 'AWDTH BWDTH'/)
iflg = 1
END IF
IF ( icalc.EQ.3 .AND. iflg.EQ.1 ) THEN
WRITE (IOUT, 9030) nn, SEG(9, nseg), SEG(10, nseg),
+ SEG(14, nseg), SEG(15, nseg)
9030 FORMAT (5X, I6, 1P4E10.3)
END IF
END DO
C
C6------PRINT TABULATED VALUES FOR COMPUTING STREAM WIDTH AND DEPTH
C FROM STREAMFLOW FOR SEGMENTS WITH ICALC=4.
iflg = 0
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
icalc = ISEG(1, nseg)
nstrpts = ISEG(2, nseg)
IF ( icalc.EQ.4 .AND. iflg.EQ.0 ) THEN
WRITE (IOUT, 9031)
9031 FORMAT (1X, /1X, 'STREAMFLOW RELATION WITH DEPTH ',
+ 'AND WIDTH IS BASED ON TABULATED VALUES', //2X,
+ 'SEGMENT NO. STREAMFLOW DEPTH ',
+ 'WIDTH', /)
iflg = 1
END IF
ipt = 1
IF ( icalc.EQ.4 .AND. iflg.EQ.1 ) THEN
DO WHILE ( ipt.LE.nstrpts )
WRITE (IOUT, 9032) nn, QSTAGE(ipt, nseg),
+ QSTAGE(nstrpts+ipt, nseg),
+ QSTAGE(2*nstrpts+ipt, nseg)
9032 FORMAT (5X, I6, 2X, 3(3X, 1PE10.4))
ipt = ipt + 1
END DO
END IF
END DO
C
C7------PRINT SOLUTE DATA FOR EACH STREAM SEGMENT.
IF ( Iunitgwt.GT.0 ) THEN
DO isol = 1, Nsol
WRITE (Iouts, 9033) isol
9033 FORMAT (1X, //10X, ' DATA FOR EACH STREAM SEGMENT:',
+ ' SOLUTE No. ', I2//5X, 'SEGMENT ',
+ 'SOLUTE CONCENTRATION IN: ', /5X,
+ 'NUMBER SEGMENT INFLOW OVERLAND FLOW', 3X,
+ 'PRECIPITATION')
DO nseg = Lstbeg, lstend
IF ( Lstbeg.EQ.1 ) THEN
nn = nseg
ELSE
nn = ISEG(3, nseg)
END IF
Cgzh Change to output
IF ( IDIVAR(1, nseg).EQ.0 ) THEN
WRITE (Iouts, 9034) nn, CONCQ(nseg, isol),
+ CONCRUN(nseg, isol),
+ CONCPPT(nseg, isol)
ELSE
WRITE (Iouts, 9035) nn, CONCRUN(nseg, isol),
+ CONCPPT(nseg, isol)
END IF
9034 FORMAT (1X, /4X, I6, 9X, 1PE10.3, 6X, E10.3, 6X, E10.3)
9035 FORMAT (1X, /4X, I6, 9X, ' N/A ', 6X, E10.3, 6X, E10.3)
END DO
END DO
WRITE (Iouts, 9036)
9036 FORMAT (//)
END IF
C
RETURN
END SUBROUTINE SGWF2SFR7PRSEG
C
C-------FUNCTION CALCUNSATFLOBOT written by RGN, MAY 24, 2004
REAL FUNCTION CALCUNSATFLOBOT(Depth, Avhc, Fks, Wetperm, Sbdthk,
+ Areamax, Strlen, Fbcheck, Nwavst,
+ Maxwav, Foldflbt)
USE GWFSFRMODULE, ONLY: NSTRAIL, ISUZN, NEARZERO
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Areamax, Avhc, Fks, Strlen
INTEGER Nwavst(ISUZN), Maxwav
DOUBLE PRECISION Wetperm, Depth, Sbdthk, Fbcheck, Foldflbt
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL flobotcheck, seep
INTEGER nstrailpls1, ii
DOUBLE PRECISION flobot, area
C ------------------------------------------------------------------
nstrailpls1 = 2*NSTRAIL + 1
seep = Avhc*(1.0D0+(Depth)/(Sbdthk))
area = Wetperm*Strlen
flobot = seep*area
IF ( flobot.GE.Fks*Areamax ) flobot = Fks*Areamax
IF ( ABS(flobot).GT.1.0D-30 ) THEN
flobotcheck = ABS(flobot/(Wetperm*Strlen)-Foldflbt
+ /(Wetperm*Strlen))
IF ( flobotcheck.LE.Fbcheck ) flobot = Foldflbt
DO ii = 1, ISUZN
IF ( Nwavst(ii).GT.Maxwav-nstrailpls1 ) flobot = 0.0D0
END DO
END IF
IF ( flobot-Fbcheck.LT.NEARZERO ) flobot = 0.0D0
CALCUNSATFLOBOT = flobot
END FUNCTION CALCUNSATFLOBOT
C
C-------SUBROUTINE CALC_UNSAT_INFIL written by RGN, MAY 24, 2004
SUBROUTINE CALC_UNSAT_INFIL(Flobot, Uzseep, Uzthst, Thr, Ha,
+ Thetas, Epsilon, Fks, Avhc, Depth,
+ Sbdthk, Wetper, Uzwdth, Flow, Nwavst,
+ Strlen, Iwidthcheck, Icalc)
C ******************************************************************
C DEFINE UNSATURATED CELLS TO ACCOMMODATE STREAM LOSS.
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: ISUZN, NSTOTRL
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Avhc, Fks, Ha, Strlen
INTEGER Iwidthcheck, Nwavst(ISUZN), Icalc
DOUBLE PRECISION Flobot, Uzseep(ISUZN), Uzthst(NSTOTRL), Depth,
+ Uzwdth(ISUZN), Flow, Sbdthk, Wetper(ISUZN), Thr,
+ Thetas, Epsilon
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL ftaken, porpress
INTEGER i, imoistcheck, iset, k, ntotuzn
DOUBLE PRECISION flobotleft, seepunsat, disconwidth, uzflobot
C ------------------------------------------------------------------
ntotuzn = NSTOTRL/ISUZN
flobotleft = Flobot
IF ( Flobot.LE.0.0D0 .OR. Flow.LE.0.0D0 ) THEN
IF ( Uzthst(1).GT.Thr .OR. Nwavst(1).GT.1 ) Uzwdth(1)
+ = Wetper(1)
DO i = 1, ISUZN
Uzseep(i) = 0.0D0
END DO
RETURN
END IF
IF ( Icalc.EQ.1 ) THEN
Uzwdth(1) = Wetper(1)
Iwidthcheck = 1
IF ( Fks.LE.Avhc ) THEN
Uzseep(1) = Fks
ELSE
Uzseep(1) = Avhc*(1.0D0+(Depth)/(Sbdthk))
END IF
uzflobot = Uzseep(1)*Uzwdth(1)*Strlen
IF ( uzflobot.GT.Flow ) Uzseep(1) = Flow/(Uzwdth(1)*Strlen)
ELSE IF ( Icalc.EQ.2 ) THEN
IF ( Uzthst(Nwavst(1)).LE.Thr ) THEN
porpress = Ha*(((Thr+.01D0)-Thr)/(Thetas-Thr))
+ **(-(1.0D0/Epsilon))
ELSE
porpress = Ha*((Uzthst(Nwavst(1))-Thr)/(Thetas-Thr))
+ **(-(1.0D0/Epsilon))
END IF
seepunsat = Avhc*(1.0D0+(Depth-porpress)/(Sbdthk))
IF ( seepunsat.GT.Fks ) seepunsat = Fks
imoistcheck = 0
disconwidth = 0.0D0
IF ( Uzthst(1).GT.Thr .OR. Nwavst(1).GT.1 ) imoistcheck = 1
IF ( Flow.GT.0.0 .OR. imoistcheck.EQ.1 ) THEN
Uzwdth(1) = Wetper(1)
Iwidthcheck = 1
disconwidth = Uzwdth(1)
ftaken = seepunsat*disconwidth*Strlen
IF ( Flobot.GT.ftaken ) THEN
Uzseep(1) = seepunsat
flobotleft = flobotleft - ftaken
ELSE
Uzseep(1) = Flobot/(disconwidth*Strlen)
flobotleft = 0.0D0
END IF
END IF
iset = 1 + ntotuzn
DO k = 2, ISUZN
imoistcheck = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(k).GT.1 ) imoistcheck = 1
IF ( flobotleft.GT.0.0 .OR. imoistcheck.EQ.1 ) THEN
Uzwdth(k) = Wetper(k)
Iwidthcheck = k
IF ( flobotleft.GT.0.0 ) THEN
disconwidth = disconwidth + Uzwdth(k)
ftaken = seepunsat*Uzwdth(k)*Strlen
IF ( flobotleft.GT.ftaken ) THEN
Uzseep(k) = seepunsat
flobotleft = flobotleft - ftaken
ELSE
Uzseep(k) = flobotleft/(Uzwdth(k)*Strlen)
flobotleft = 0.0D0
END IF
END IF
END IF
iset = iset + ntotuzn
END DO
END IF
C-------RETURN.
RETURN
END SUBROUTINE CALC_UNSAT_INFIL
C
C-------SUBROUTINE UZMASSBAL written MAY 24, 2004
SUBROUTINE UZMASSBAL(L, H, Hld, Thr, Thetas, Epsilon, Fks, Uzdpst,
+ Uzthst, Uzspst, Uzflst, Ltrlst, Itrlst,
+ Uzflwt, Uzstor, Delstor, Nwavst, Uzolsflx,
+ Uzwdth, Wetper, Uzseep, Ratin, Ratout,
+ Il, Ir, Ic, Flobot, Sbot, Strlen, Totflwt,
+ Totuzstor, Totdelstor, Iwidthcheck, Avdpt,
+ Avwat, Wat1, Ibd, Icalc, Deltinc, Imassroute,
+ Iunitgage, Gwflow)
!rsr unused arguments Kkper, Kkstp, Irt
C ******************************************************************
C COMPUTE INFLOW, OUTFLOW, AND CHANGE IN STORAGE IN UNSATURATED
C ZONE BENEATH STREAMBED.
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: ISUZN,NSTOTRL,NUMAVE,STRM,ITRLSTH,SFRUZBD,
+ SUMLEAK,SUMRCH, NEARZERO, CLOSEZERO
USE GLOBAL, ONLY: BUFF,IOUT
! USE GWFBASMODULE, ONLY: DELT
IMPLICIT NONE
INTRINSIC ABS, DABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER L, Il, Ir, Ic, Iwidthcheck, Ibd, Icalc, Imassroute
INTEGER Nwavst(ISUZN), Itrlst(NSTOTRL), Ltrlst(NSTOTRL)
INTEGER Iunitgage
REAL Fks, Strlen, Deltinc, Avdpt(NUMAVE), Avwat(NUMAVE),
+ Wat1(NUMAVE)
DOUBLE PRECISION Uzwdth(ISUZN), Uzflwt(ISUZN), Uzolsflx(ISUZN),
+ Uzseep(ISUZN), Uzstor(ISUZN), Delstor(ISUZN),
+ Wetper(ISUZN)
DOUBLE PRECISION Uzspst(NSTOTRL), Uzflst(NSTOTRL),
+ Uzdpst(NSTOTRL), Uzthst(NSTOTRL)
DOUBLE PRECISION H, Hld, Thr, Thetas, Epsilon, Ratin, Ratout,
+ Flobot, Sbot, Totflwt, Totuzstor, Totdelstor,
+ Gwflow
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL depthinc, depthsave, fhold, hdif, htest1, htest2, seep,
+ totalwc, totalwc1, uzstorhold, widthsave, ftheta1, ftheta2,
+ eps_m1
!rsr REAL tottot
INTEGER i, ick, icounter, iflag, ii, iset, j, jj, jk, k, kk,
+ numwavhld, nwavecheck, iuznhold, ntotuzn, jm1
DOUBLE PRECISION strtop, fm, fluxdif
INTEGER loop
ALLOCATABLE loop(:)
ALLOCATE (loop(ISUZN))
C
C1------INITIALIZE VARIABLES.
C
iflag = 0
Totflwt = 0.0D0
Totdelstor = 0.0D0
Totuzstor = 0.0D0
strtop = STRM(3, L)
htest1 = H - Sbot
htest2 = Hld - Sbot
hdif = ABS(H-Hld)
eps_m1 = Epsilon - 1.0D0
fluxdif = 0.0D0
iflag = 0
iset = 1
ntotuzn = NSTOTRL/ISUZN
iuznhold = 0
IF ( Icalc.EQ.2 ) THEN
iuznhold = ISUZN
ELSE IF ( Icalc.EQ.1 ) THEN
iuznhold = 1
END IF
nwavecheck = 0
DO i = 1, iuznhold
fluxdif = fluxdif + DABS(Uzseep(i)-Uzolsflx(i))
nwavecheck = nwavecheck + Nwavst(i)
END DO
IF ( fluxdif.LT.5.0E-10 ) iflag = 1
C
C1A---- NO UNSATURATED ZONE
IF ( htest1.GE.-CLOSEZERO .AND. htest2.GE.-CLOSEZERO ) THEN
iset = 1
DO i = 1, iuznhold
Delstor(i) = 0.0D0
Uzstor(i) = 0.0D0
Uzdpst(iset) = 0.0D0
Uzthst(iset) = Thr
iset = iset + ntotuzn
END DO
IF ( Imassroute.EQ.1 ) THEN
IF ( Flobot.LT.0.0D0 ) THEN
Ratout = Ratout - SUMLEAK(L)
SFRUZBD(9) = SFRUZBD(9) - SUMLEAK(L)
ELSE
Ratin = Ratin + SUMLEAK(L)
SFRUZBD(8) = SFRUZBD(8) + SUMLEAK(L)
END IF
Gwflow = SUMLEAK(L)
BUFF(Ic, Ir, Il) = BUFF(Ic, Ir, Il) + Gwflow
END IF
C
C2------REMOVE ALL UNSATURATED ZONE WAVES AND CALCULATE CHANGE IN
C STORAGE WHEN WATER TABLE RISES TO ELEVATION OF STREAMBED.
ELSE IF ( htest1.GE.-CLOSEZERO .AND. htest2.LT.-CLOSEZERO ) THEN
DO kk = 1, iuznhold
loop(kk) = 0
END DO
iset = 1
DO i = 1, iuznhold
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( i.LE.Iwidthcheck .OR. ick.EQ.1 ) loop(i) = 1
iset = iset + ntotuzn
END DO
iset = 1
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
ick = 0
Delstor(i) = Uzstor(i)
Uzstor(i) = 0.0D0
END IF
iset = iset + ntotuzn
END DO
CALL ROUTWAVESST(L, seep, H, Hld, Thr, Thetas, Fks, Epsilon,
+ Iwidthcheck, strtop, Icalc, Nwavst, Uzwdth,
+ Uzflwt, Uzolsflx, Uzseep, Itrlst, Ltrlst,
+ Uzspst, Uzflst, Uzdpst, Uzthst, Deltinc)
iset = 1
DO kk = 1, iuznhold
loop(kk) = 0
END DO
DO i = 1, iuznhold
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( i.LE.Iwidthcheck .OR. ick.EQ.1 ) loop(i) = 1
iset = iset + ntotuzn
END DO
iset = 1
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
Uzdpst(iset) = 0.0D0
Uzthst(iset) = Thr
Uzflst(iset) = 0.0D0
Uzspst(iset) = 0.0D0
Itrlst(iset) = 0
Ltrlst(iset) = 0
Nwavst(i) = 1
DO ii = iset + 1, (iset+ntotuzn) - 1
Uzdpst(ii) = 0.0D0
Uzthst(ii) = Thr
Uzflst(ii) = 0.0D0
Uzspst(ii) = 0.0D0
Itrlst(ii) = 0
Ltrlst(ii) = 0
END DO
END IF
iset = iset + ntotuzn
END DO
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
Uzolsflx(i) = 0.0D0
Totflwt = Totflwt + Uzflwt(i)
Totdelstor = Totdelstor + Delstor(i)
END IF
END DO
SUMRCH(L) = SUMRCH(L) + Totflwt
STRM(29,L) = STRM(29,L) + Totdelstor
IF ( Imassroute.EQ.1 ) THEN
IF ( Flobot.LT.0.0D0 ) THEN
Ratout = Ratout - SUMLEAK(L)
Ratin = Ratin + SUMRCH(L)/deltinc
SFRUZBD(2) = SFRUZBD(2) - SUMRCH(L)
SFRUZBD(3) = SFRUZBD(3) + SUMRCH(L)
SFRUZBD(5) = SFRUZBD(5) - SUMRCH(L)/deltinc
SFRUZBD(6) = SFRUZBD(6) + SUMRCH(L)/deltinc
SFRUZBD(9) = SFRUZBD(9) - SUMLEAK(L)
ELSE
Ratin = Ratin + SUMLEAK(L) + SUMRCH(L)/deltinc
SFRUZBD(2) = SFRUZBD(2) - SUMRCH(L)
SFRUZBD(3) = SFRUZBD(3) + SUMRCH(L)
SFRUZBD(5) = SFRUZBD(5) - SUMRCH(L)/deltinc
SFRUZBD(6) = SFRUZBD(6) + SUMRCH(L)/deltinc
SFRUZBD(8) = SFRUZBD(8) + SUMLEAK(L)
END IF
Gwflow = SUMLEAK(L) + SUMRCH(L)/deltinc
BUFF(Ic, Ir, Il) = BUFF(Ic, Ir, Il) + Gwflow
END IF
C
C3------CALCULATE CHANGE IN STORAGE AND UPDATE UNSATURATED ZONE WAVES
C WHEN WATER TABLE REMAINS BELOW STREAMBED ELEVATION.
ELSE IF ( hdif.LT.2.0E-4 .AND. nwavecheck.EQ.iuznhold .AND.
+ iflag.EQ.1 .AND. htest1.LT.2.0E-3 ) THEN
iset = 1
DO i = 1, iuznhold
Delstor(i) = 0.0D0
Uzdpst(iset) = Uzdpst(iset) - (H-Hld)
Uzstor(i) = Uzdpst(iset)*(Uzthst(iset)-Thr)*Uzwdth(i)*Strlen
SFRUZBD(10) = SFRUZBD(10) + Uzstor(i)
Uzflwt(i) = Uzseep(i)*Uzwdth(i)*Strlen*Deltinc
Uzolsflx(i) = Uzseep(i)
SUMRCH(L) = SUMRCH(L) + Uzflwt(i)
iset = iset + ntotuzn
END DO
STRM(29,L) = 0.0
IF ( Imassroute.EQ.1 ) THEN
Ratin = Ratin + SUMRCH(L)/deltinc
Gwflow = SUMRCH(L)/deltinc
BUFF(Ic, Ir, Il) = BUFF(Ic, Ir, Il) + Gwflow
SFRUZBD(1) = SFRUZBD(1) + SUMLEAK(L)*deltinc
SFRUZBD(2) = SFRUZBD(2) + STRM(29,L)
SFRUZBD(3) = SFRUZBD(3) + SUMRCH(L)
SFRUZBD(4) = SFRUZBD(4) + SUMLEAK(L)
SFRUZBD(5) = SFRUZBD(5) + STRM(29,L)/deltinc
SFRUZBD(6) = SFRUZBD(6) + SUMRCH(L)/deltinc
SFRUZBD(8) = SFRUZBD(8) + SUMLEAK(L)
SFRUZBD(7) = SFRUZBD(7) + SUMLEAK(L)
END IF
C
ELSE IF ( htest1.LT.-CLOSEZERO .AND. htest2.LT.-CLOSEZERO ) THEN
CALL ROUTWAVESST(L, seep, H, Hld, Thr, Thetas, Fks, Epsilon,
+ Iwidthcheck, strtop, Icalc, Nwavst, Uzwdth,
+ Uzflwt, Uzolsflx, Uzseep, Itrlst, Ltrlst,
+ Uzspst, Uzflst, Uzdpst, Uzthst, Deltinc)
DO kk = 1, iuznhold
loop(kk) = 0
END DO
iset = 1
DO i = 1, iuznhold
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( i.LE.Iwidthcheck .OR. ick.EQ.1 ) loop(i) = 1
iset = iset + ntotuzn
END DO
iset = 1
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
C
C4------CALCULATE CHANGE IN UNSATURATED ZONE STORAGE WHEN WATER TABLE
C RISES.
IF ( H.GT.Hld ) THEN
fm = 0.0D0
depthsave = Uzdpst(iset)
jj = iset
DO jk = iset+1, iset+Nwavst(i)-1
IF ( ((Sbot-Uzdpst(jk)).LE.H) ) jj = jk
END DO
jk = iset + 1
C
C5------WATER TABLE RISES THROUGH WAVES.
IF ( jj.GE.jk ) THEN
DO j = iset, iset + Nwavst(i) - 1
ITRLSTH(j) = Itrlst(j)
END DO
numwavhld = Nwavst(i)
Nwavst(i) = Nwavst(i) - (jj-iset)
Uzdpst(iset) = depthsave - (H-Hld)
Uzthst(iset) = Uzthst(jj)
Uzflst(iset) = Uzflst(jj)
Uzspst(iset) = 0.0D0
Itrlst(iset) = 0
Ltrlst(iset) = 0
k = iset + 1
DO j = jj + 1, iset + numwavhld - 1
Uzdpst(k) = Uzdpst(j)
Uzthst(k) = Uzthst(j)
Uzflst(k) = Uzflst(j)
Uzspst(k) = Uzspst(j)
Itrlst(k) = Itrlst(j)
Ltrlst(k) = Ltrlst(j)
k = k + 1
END DO
C
C6------LOOP THROUGH NUMBER OF TRAIL WAVES INTERSECTED BY WATER TABLE.
DO j = iset, jj + 1
IF ( j.EQ.jj+1 ) THEN
IF ( ITRLSTH(j).GT.0 ) THEN
C
C7------LEAD TRAIL WAVE BELOW WATER TABLE AND FIRST TRAIL WAVE IS
C ABOVE WATER TABLE.
IF ( ITRLSTH(j).EQ.1 ) THEN
jm1 = j - 1
Ltrlst(jm1) = 1
Itrlst(jm1) = 0
fhold = (Uzthst(jm1)-Thr)/(Thetas-Thr)
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
IF ( DABS(Uzthst(jm1)-Uzthst(j-2)).LT.NEARZERO )
+ THEN
fhold = ((Uzthst(jm1)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
Uzspst(jm1) = (Epsilon*Fks/(Thetas-Thr))*fhold
+ **eps_m1
ELSE
fhold = ((Uzthst(j-2)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta1 = Fks*fhold
fhold = ((Uzthst(jm1)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta2 = Fks*fhold
Uzspst(jm1) = (ftheta1-ftheta2)
+ /(Uzthst(j-2)-Uzthst(jm1))
END IF
ELSE
C
C8------LEAD TRAIL WAVE BELOW WATER TABLE AND MULTIPLE TRAIL WAVES
C ABOVE WATER TABLE.
DO k = iset + 1, iset + ITRLSTH(j)
Ltrlst(k) = 1
Itrlst(k) = 0
fhold = (Uzthst(k)-Thr)/(Thetas-Thr)
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
IF ( DABS(Uzthst(k)-Uzthst(k-1)).LT.NEARZERO )
+ THEN
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
Uzspst(k) = (Epsilon*Fks/(Thetas-Thr))*fhold
+ **eps_m1
ELSE
fhold = ((Uzthst(k-1)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta1 = Fks*fhold
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta2 = Fks*fhold
Uzspst(k) = (ftheta1-ftheta2)
+ /(Uzthst(k-1)-Uzthst(k))
END IF
END DO
END IF
END IF
ELSE IF ( j.NE.jj ) THEN
C
C9------MULTIPLE TRAIL WAVES BELOW AND ABOVE WATER TABLE.
IF ( ITRLSTH(j).GT.jj-j+1 ) THEN
DO k = iset + 1, iset + ITRLSTH(j) - (jj-j) - 1
Ltrlst(k) = 1
Itrlst(k) = 0
fhold = (Uzthst(k)-Thr)/(Thetas-Thr)
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
IF ( DABS(Uzthst(k)-Uzthst(k-1)).LT.NEARZERO )
+ THEN
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
Uzspst(k) = (Epsilon*Fks/(Thetas-Thr))*fhold
+ **eps_m1
ELSE
fhold = ((Uzthst(k-1)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta1 = Fks*fhold
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta2 = Fks*fhold
Uzspst(k) = (ftheta1-ftheta2)
+ /(Uzthst(k-1)-Uzthst(k))
END IF
END DO
END IF
C
C10-----ONLY ONE LEAD TRAIL AND ONE TRAIL WAVE BELOW WATER TABLE
C AND THERE ARE MUTIPLE TRAIL WAVES IN SET ABOVE WATER TABLE.
ELSE IF ( ITRLSTH(j).GT.1 ) THEN
DO k = iset + 1, iset + ITRLSTH(j) - 1
Ltrlst(k) = 1
Itrlst(k) = 0
IF ( DABS(Uzthst(k)-Uzthst(k-1)).LT.NEARZERO )
+ THEN
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
Uzspst(k) = (Epsilon*Fks/(Thetas-Thr))*fhold
+ **eps_m1
ELSE
fhold = ((Uzthst(k-1)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta1 = Fks*fhold
fhold = ((Uzthst(k)-Thr)/(Thetas-Thr))
+ **Epsilon
IF ( fhold.LT.CLOSEZERO ) fhold = 0.0
ftheta2 = Fks*fhold
Uzspst(k) = (ftheta1-ftheta2)
+ /(Uzthst(k-1)-Uzthst(k))
END IF
END DO
END IF
END DO
C
C11-----DETERMINE VOLUME OF WATER IN WAVES BELOW WATER TABLE.
fm = 0.0D0
j = iset
DO WHILE ( j.LE.iset+Nwavst(i)-2 )
IF ( Ltrlst(j).EQ.1 .AND. Itrlst(j+1).GT.0 ) THEN
k = j
DO WHILE ( k.LE.j+Itrlst(j+1)-1 )
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
k = k + 1
END DO
IF ( k.EQ.iset+Nwavst(i)-1 ) THEN
fm = fm + (Uzthst(k)-Thr)*Uzdpst(k)
ELSE IF ( iset+Nwavst(i)-1.GT.k+1 .AND. Itrlst(k+2)
+ .GT.0 .AND. Ltrlst(k+1).EQ.1 ) THEN
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
ELSE
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
END IF
j = k
ELSE
fm = fm + (Uzthst(j)-Thr)*(Uzdpst(j)-Uzdpst(j+1))
END IF
j = j + 1
END DO
IF ( j.EQ.iset+Nwavst(i)-1 ) fm = fm +
+ (Uzthst(iset+Nwavst(i)-1)-Thr)
+ *Uzdpst(iset+Nwavst(i)-1)
C
C12-----COMPUTE VOLUME OF WATER BELOW WATER TABLE WHEN
C WHEN NO WAVES INTERSECTED.
ELSE
fm = 0.0D0
j = iset
Uzdpst(iset) = Uzdpst(iset) - (H-Hld)
DO WHILE ( j.LE.iset+Nwavst(i)-2 )
IF ( Ltrlst(j).EQ.1 .AND. Itrlst(j+1).GT.0 ) THEN
k = j
DO WHILE ( k.LE.j+Itrlst(j+1)-1 )
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
k = k + 1
END DO
IF ( k.EQ.iset+Nwavst(i)-1 ) THEN
fm = fm + (Uzthst(k)-Thr)*Uzdpst(k)
ELSE IF ( iset+Nwavst(i)-1.GT.k+1 .AND. Itrlst(k+2)
+ .GT.0 .AND. Ltrlst(k+1).EQ.1 ) THEN
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
ELSE
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
END IF
j = k
ELSE
fm = fm + (Uzthst(j)-Thr)*(Uzdpst(j)-Uzdpst(j+1))
END IF
j = j + 1
END DO
IF ( j.EQ.iset+Nwavst(i)-1 ) fm = fm +
+ (Uzthst(iset+Nwavst(i)-1)-Thr)
+ *Uzdpst(iset+Nwavst(i)-1)
END IF
IF ( fm.LT.0.0 ) fm = 0.0D0
uzstorhold = Uzstor(i)
Uzstor(i) = fm*Uzwdth(i)*Strlen
Delstor(i) = Uzstor(i) - uzstorhold
C
C13-----CALCULATE CHANGE IN UNSATURATED ZONE STORAGE WHEN GROUND-
C WATER LEVEL DROPS.
ELSE IF ( H.LE.Hld ) THEN
fm = 0.0D0
j = iset
DO WHILE ( j.LE.iset+Nwavst(i)-2 )
IF ( Ltrlst(j).EQ.1 .AND. Itrlst(j+1).GT.0 ) THEN
k = j
DO WHILE ( k.LE.j+Itrlst(j+1)-1 )
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
k = k + 1
END DO
IF ( k.EQ.iset+Nwavst(i)-1 ) THEN
fm = fm + (Uzthst(k)-Thr)*Uzdpst(k)
ELSE IF ( iset+Nwavst(i)-1.GT.k+1 .AND. Itrlst(k+2)
+ .GT.0 .AND. Ltrlst(k+1).EQ.1 ) THEN
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
ELSE
fm = fm + (Uzthst(k)-Thr)*(Uzdpst(k)-Uzdpst(k+1))
END IF
j = k
ELSE
fm = fm + (Uzthst(j)-Thr)*(Uzdpst(j)-Uzdpst(j+1))
END IF
j = j + 1
END DO
IF ( j.EQ.iset+Nwavst(i)-1 ) fm = fm +
+ (Uzthst(iset+Nwavst(i)-1)-Thr)
+ *Uzdpst(iset+Nwavst(i)-1)
uzstorhold = Uzstor(i)
Uzstor(i) = fm*Uzwdth(i)*Strlen
Delstor(i) = Uzstor(i) - uzstorhold
END IF
IF ( Uzflwt(i).LE.0.0 ) Uzflwt(i) = 0.0D0
END IF
iset = iset + ntotuzn
END DO
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
Totflwt = Totflwt + Uzflwt(i)
Totdelstor = Totdelstor + Delstor(i)
Totuzstor = Totuzstor + Uzstor(i)
END IF
END DO
SUMRCH(L) = SUMRCH(L) + Totflwt
STRM(29,L) = STRM(29,L) + Totdelstor
IF ( Imassroute.EQ.1 ) THEN
Gwflow = SUMRCH(L)/deltinc
Ratin = Ratin + Gwflow
BUFF(Ic, Ir, Il) = BUFF(Ic, Ir, Il) + Gwflow
SFRUZBD(1) = SFRUZBD(1) + SUMLEAK(L)*deltinc
SFRUZBD(2) = SFRUZBD(2) + STRM(29,L)
SFRUZBD(3) = SFRUZBD(3) + SUMRCH(L)
SFRUZBD(4) = SFRUZBD(4) + SUMLEAK(L)
SFRUZBD(5) = SFRUZBD(5) + STRM(29,L)/deltinc
SFRUZBD(6) = SFRUZBD(6) + SUMRCH(L)/deltinc
SFRUZBD(8) = SFRUZBD(8) + SUMLEAK(L)
SFRUZBD(7) = SFRUZBD(7) + SUMLEAK(L)
SFRUZBD(10) = SFRUZBD(10) + Totuzstor
END IF
C
C14-----UPDATE ALL UNSATURATED ZONE WAVES WHEN WATER TABLE DROPS
C BELOW STREAMBED.
ELSE IF ( htest1.LE.-CLOSEZERO .AND. htest2.GE.-CLOSEZERO ) THEN
iset = 1
DO i = 1, iuznhold
Delstor(i) = 0.0D0
Nwavst(i) = 1
DO j = iset, iset + 5
Uzthst(j) = Thr
Uzdpst(j) = 0.0D0
Uzspst(j) = 0.0D0
Uzflst(j) = 0.0D0
Itrlst(j) = 0
Ltrlst(j) = 0
END DO
iset = iset + ntotuzn
END DO
CALL ROUTWAVESST(L, seep, H, Hld, Thr, Thetas, Fks, Epsilon,
+ Iwidthcheck, Sbot, Icalc, Nwavst, Uzwdth,
+ Uzflwt, Uzolsflx, Uzseep, Itrlst, Ltrlst,
+ Uzspst, Uzflst, Uzdpst, Uzthst, Deltinc)
DO kk = 1, iuznhold
loop(kk) = 0
END DO
iset = 1
DO i = 1, iuznhold
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( i.LE.Iwidthcheck .OR. ick.EQ.1 ) loop(i) = 1
iset = iset + ntotuzn
END DO
iset = 1
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
icounter = iset + Nwavst(i) - 1
Delstor(i) = (Uzthst(icounter)-Thr)*(Uzdpst(icounter))
DO j = iset, iset + Nwavst(i) - 2
Delstor(i) = Delstor(i) + (Uzthst(j)-Thr)
+ *(Uzdpst(j)-Uzdpst(j+1))
END DO
Delstor(i) = Delstor(i)*Uzwdth(i)*Strlen
Uzstor(i) = Delstor(i)
END IF
iset = iset + ntotuzn
END DO
DO i = 1, iuznhold
IF ( loop(i).GT.0 ) THEN
Totflwt = Totflwt + Uzflwt(i)
Totdelstor = Totdelstor + Delstor(i)
Totuzstor = Totuzstor + Uzstor(i)
END IF
END DO
SUMRCH(L) = SUMRCH(L) + Totflwt
STRM(29,L) = STRM(29,L) + Totdelstor
C
C15-----UPDATE RATES AND BUFFERS.
C
IF ( Imassroute.EQ.1 ) THEN
Gwflow = SUMRCH(L)/deltinc
Ratin = Ratin + Gwflow
BUFF(Ic, Ir, Il) = BUFF(Ic, Ir, Il) + Gwflow
SFRUZBD(1) = SFRUZBD(1) + SUMLEAK(L)*deltinc
SFRUZBD(2) = SFRUZBD(2) + STRM(29,L)
SFRUZBD(3) = SFRUZBD(3) + SUMRCH(L)
SFRUZBD(4) = SFRUZBD(4) + SUMLEAK(L)
SFRUZBD(5) = SFRUZBD(5) + STRM(29,L)/deltinc
SFRUZBD(6) = SFRUZBD(6) + SUMRCH(L)/deltinc
SFRUZBD(7) = SFRUZBD(7) + SUMLEAK(L)
SFRUZBD(8) = SFRUZBD(8) + SUMLEAK(L)
SFRUZBD(10) = SFRUZBD(10) + Totuzstor
END IF
END IF
C
C16-----TOTAL WATER CONTENT OVER SPECIFIED DEPTH
C FOR PRINTING WATER CONTENT PROFILES.
IF ( Ibd.NE.0 .AND. Iunitgage.GT.0 ) THEN
IF ( H.LT.Sbot ) THEN
depthinc = Uzdpst(1)/20.001D0
depthsave = depthinc
totalwc = 0.0
totalwc1 = 0.0
k = 1
DO WHILE ( depthsave.LE.Uzdpst(1) .AND. depthsave.GT.0.0 )
widthsave = 0.0
iset = 1
fm = 0.0D0
DO i = 1, iuznhold
widthsave = widthsave + Wetper(i)
jj = iset
jk = iset + Nwavst(i) - 1
DO WHILE ( jk.GE.iset )
IF ( Uzdpst(jk).LT.depthsave ) jj = jk
jk = jk - 1
END DO
IF ( jj.GT.iset ) THEN
fm = fm + Uzthst(jj-1)*(depthsave-Uzdpst(jj))*Wetper(i)
+ *Strlen
DO j = jj, iset + Nwavst(i) - 2
fm = fm + Uzthst(j)*(Uzdpst(j)-Uzdpst(j+1))*Wetper(i)
+ *Strlen
END DO
fm = fm + Uzthst(iset+Nwavst(i)-1)
+ *Uzdpst(iset+Nwavst(i)-1)*Wetper(i)*Strlen
ELSE
fm = fm + Uzthst(iset+Nwavst(i)-1)*depthsave*Wetper(i)
+ *Strlen
END IF
IF ( i.EQ.1 ) THEN
Wat1(k) = (fm-totalwc1)/(widthsave*Strlen*depthinc)
totalwc1 = fm
END IF
iset = iset + ntotuzn
END DO
Avdpt(k) = depthsave
Avwat(k) = (fm-totalwc)/(widthsave*Strlen*depthinc)
totalwc = fm
depthsave = depthsave + depthinc
k = k + 1
END DO
END IF
END IF
C17-----STORE UNSATURATED FLOW RATES FOR GAGE PACKAGE.
STRM(21, L) = Totflwt/Deltinc
STRM(22, L) = Totdelstor/Deltinc
STRM(23, L) = Totuzstor
DEALLOCATE (loop)
C18-----RETURN.
RETURN
END SUBROUTINE UZMASSBAL
C
C-------SUBROUTINE ROUTWAVESIT
SUBROUTINE ROUTWAVESIT(L, Seep, H, Hld, Thr, Thetas, Fks, Epsilon,
+ Icalc, Nwavst, Uzwdth, Uzflwt, Uzolsflx,
+ Uzseep, Itrlst, Ltrlst, Uzspst, Uzflst,
+ Uzdpst, Uzthst, Itrlit, Ltrlit, Uzspit,
+ Uzflit, Uzdpit, Uzthit, Deltinc, Sbot)
C ******************************************************************
C ROUTE UNSATURATED ZONE WAVES DURING MODEL ITERATIONS
C CALLED FROM SUBROUTINE GWF2SFR7FM
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
C
USE GWFSFRMODULE, ONLY: NSTOTRL, ISUZN, STRM, CLOSEZERO
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Fks, Seep, Deltinc
INTEGER L, Icalc
INTEGER Nwavst(ISUZN), Itrlst(NSTOTRL), Ltrlst(NSTOTRL)
INTEGER Itrlit(NSTOTRL), Ltrlit(NSTOTRL)
DOUBLE PRECISION Uzwdth(ISUZN), Uzflwt(ISUZN), Uzolsflx(ISUZN),
+ Uzseep(ISUZN), Sbot
DOUBLE PRECISION Uzspst(NSTOTRL), Uzflst(NSTOTRL),
+ Uzdpst(NSTOTRL), Uzthst(NSTOTRL)
DOUBLE PRECISION Uzspit(NSTOTRL), Uzflit(NSTOTRL),
+ Uzdpit(NSTOTRL), Uzthit(NSTOTRL)
DOUBLE PRECISION H, Hld, Thr, Thetas, Epsilon
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER i, ick, iset, iwav, numwaves, iuzntemp, ntotuzn
DOUBLE PRECISION dlength, zoldist, totflux, surflux, oldsflx,
+ htest2
C -----------------------------------------------------------------
C
C1------ROUTE WAVES THROUGH EACH UNSATURATED ZONE COMPARTMENT BENEATH
C STREAM.
htest2 = Hld - Sbot
iset = 1
iuzntemp = 0
IF ( Icalc.EQ.2 ) THEN
iuzntemp = ISUZN
ELSE IF ( Icalc.EQ.1 ) THEN
iuzntemp = 1
ENDIF
ntotuzn = NSTOTRL/ISUZN
DO i = 1, iuzntemp
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( Uzwdth(i).LE.0.0 ) Seep = 0.0
IF ( Uzwdth(i).GT.0.0 .OR. ick.EQ.1 ) THEN
numwaves = Nwavst(i)
IF ( htest2.GE.-2.0*CLOSEZERO ) THEN
DO iwav = iset, iset + 5
Uzthit(iwav) = Thr
Uzdpit(iwav) = 0.0D0
Uzspit(iwav) = 0.0D0
Uzflit(iwav) = 0.0D0
Itrlit(iwav) = 0
Ltrlit(iwav) = 0
Nwavst(i) = 1
numwaves = 1
END DO
ELSE
DO iwav = iset, iset + numwaves - 1
Uzthit(iwav) = Uzthst(iwav)
Uzdpit(iwav) = Uzdpst(iwav)
Uzspit(iwav) = Uzspst(iwav)
Uzflit(iwav) = Uzflst(iwav)
Itrlit(iwav) = Itrlst(iwav)
Ltrlit(iwav) = Ltrlst(iwav)
END DO
END IF
dlength = Uzdpst(iset) + Hld - H
zoldist = Uzdpst(iset)
IF ( dlength.LT.0.0 ) dlength = 0.0D0
IF ( zoldist.LT.0.0 ) zoldist = 0.0D0
surflux = Uzseep(i)
oldsflx = Uzolsflx(i)
CALL UZFLOW(L, surflux, dlength, zoldist, Uzdpit, Uzthit,
+ Uzflit, Uzspit, Itrlit, Ltrlit, totflux,
+ numwaves, Thr, Thetas, Fks, Epsilon, oldsflx,
+ iset, Deltinc)
IF ( totflux.LT.0.0 ) totflux = 0.0D0
Uzflwt(i) = totflux*Uzwdth(i)*STRM(1, L)
IF ( Uzflwt(i).LT.0.0 ) Uzflwt(i) = 0.0D0
ELSE
Uzflwt(i) = 0.0D0
END IF
iset = iset + ntotuzn
END DO
C
C2------RETURN.
RETURN
END SUBROUTINE ROUTWAVESIT
C
C-------SUBROUTINE ROUTWAVESST
SUBROUTINE ROUTWAVESST(L, Seep, H, Hld, Thr, Thetas, Fks, Epsilon,
+ Iwidthcheck, Sbot, Icalc, Nwavst, Uzwdth,
+ Uzflwt, Uzolsflx, Uzseep, Itrlst, Ltrlst,
+ Uzspst, Uzflst, Uzdpst, Uzthst, Deltinc)
C ******************************************************************
C ROUTE UNSATURATED-ZONE WAVES AFTER FINAL ITERATION
C CALLED FROM SUBROUTINE GWF2SFR7BD
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NSTOTRL, ISUZN, STRM, NEARZERO
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC DABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Fks, Seep, Deltinc
INTEGER Iwidthcheck, L, Icalc
INTEGER Nwavst(ISUZN), Itrlst(NSTOTRL), Ltrlst(NSTOTRL)
DOUBLE PRECISION Uzwdth(ISUZN), Uzflwt(ISUZN), Uzolsflx(ISUZN),
+ Uzseep(ISUZN)
DOUBLE PRECISION Uzspst(NSTOTRL), Uzflst(NSTOTRL),
+ Uzdpst(NSTOTRL), Uzthst(NSTOTRL)
DOUBLE PRECISION H, Hld, Thr, Thetas, Epsilon, Sbot
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER i, ick, iset, numwaves, iuzntemp
DOUBLE PRECISION dlength, zoldist, totflux, surflux, oldsflx
C -----------------------------------------------------------------
C
C1------ROUTE WAVES THROUGH EACH UNSATURATED ZONE COMPARTMENT BENEATH
C STREAM.
iset = 1
Sbot = STRM(4, L)
iuzntemp = 0
IF ( Icalc.EQ.2 ) THEN
iuzntemp = ISUZN
ELSE IF ( Icalc.EQ.1 ) THEN
iuzntemp = 1
ENDIF
DO i = 1, iuzntemp
ick = 0
IF ( Uzthst(iset).GT.Thr .OR. Nwavst(i).GT.1 ) ick = 1
IF ( i.GT.Iwidthcheck ) Seep = 0.0
IF ( i.LE.Iwidthcheck .OR. ick.EQ.1 ) THEN
numwaves = Nwavst(i)
IF ( DABS(Uzdpst(iset)).GT.NEARZERO ) THEN
dlength = Uzdpst(iset) + Hld - H
zoldist = Uzdpst(iset)
ELSE
dlength = Sbot - H
zoldist = 0.0D0
END IF
IF ( dlength.LT.0.0 ) dlength = 0.0D0
IF ( zoldist.LT.0.0 ) zoldist = 0.0D0
surflux = Uzseep(i)
oldsflx = Uzolsflx(i)
CALL UZFLOW(L, surflux, dlength, zoldist, Uzdpst, Uzthst,
+ Uzflst, Uzspst, Itrlst, Ltrlst, totflux,
+ numwaves, Thr, Thetas, Fks, Epsilon, oldsflx,
+ iset, Deltinc)
Nwavst(i) = numwaves
Uzflwt(i) = totflux*Uzwdth(i)*STRM(1, L)
IF ( Uzflwt(i).LT.0.0 ) Uzflwt(i) = 0.0D0
ELSE
Uzflwt(i) = 0.0D0
Uzdpst(iset) = Uzdpst(1)
END IF
Uzolsflx(i) = Uzseep(i)
iset = iset + NSTOTRL/ISUZN
END DO
C2------RETURN.
RETURN
END SUBROUTINE ROUTWAVESST
C
C-------SUBROUTINE UZFLOW
SUBROUTINE UZFLOW(I, Surflux, Dlength, Zoldist, Depth, Theta,
+ Flux, Speed, Itrwave, Ltrail, Totalflux,
+ Numwaves, Thetar, Thetas, Fksat, Eps, Oldsflx,
+ Jpnt, Deltinc)
C ******************************************************************
C WAVE INTERACTION WITHIN AN UNSATURATED FLOW COMPARTMENT
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NSTOTRL, NSFRSETS, NSTRAIL, THETAB, FLUXB
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC ABS, DABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER I, Jpnt, Numwaves, Itrwave(NSTOTRL), Ltrail(NSTOTRL)
REAL Fksat, Deltinc
DOUBLE PRECISION Depth(NSTOTRL), Theta(NSTOTRL), Flux(NSTOTRL),
+ Speed(NSTOTRL)
DOUBLE PRECISION Dlength, Zoldist, Totalflux, Surflux, Oldsflx,
+ Thetar, Thetas, Eps
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION ffcheck, feps2, feps, time, fm, dlength2
REAL thetadif
INTEGER itester, j, jj, jm1, itrailflg
C ------------------------------------------------------------------
time = 0.0D0
Totalflux = 0.0D0
feps = 1.0D-12/Deltinc
feps2 = 1.0D-12/Deltinc
itrailflg = 0
C
C FEPS IS USED TO SUPPRESS A NEW WAVE WHEN CHANGES IN WATER TABLE
C ARE NEGLIGIBLE. FEPS2 IS USED TO SUPPRESS A NEW WAVE WHEN
C CHANGES IN FLUX ARE NEGLIGIBLE.
IF ( feps.LT.1.0D-8 ) feps = 1.0D-8
IF ( feps2.LT.5.0D-8 ) feps2 = 5.0D-8
fm = 0.0D0
Oldsflx = Flux(Jpnt+Numwaves-1)
C
C1------DETERMINE IF WATER TABLE IS RISING OR FALLING.
IF ( (Dlength-Zoldist).LT.-feps ) THEN
dlength2 = Dlength
Dlength = Zoldist
ELSE IF ( (Dlength-Zoldist).GT.feps ) THEN
dlength2 = Zoldist + 1.0D0
thetadif = ABS(Theta(Jpnt)-Thetar)
IF ( thetadif.GT.1.0E-6 ) THEN
DO j = Jpnt + Numwaves, Jpnt + 1, -1
jm1 = j - 1
Theta(j) = Theta(jm1)
Flux(j) = Flux(jm1)
Speed(j) = Speed(jm1)
Depth(j) = Depth(jm1)
Itrwave(j) = Itrwave(jm1)
Ltrail(j) = Ltrail(jm1)
END DO
IF ( Theta(Jpnt+1).GT.Thetar ) THEN
Speed(Jpnt+1) = Flux(Jpnt+1)/(Theta(Jpnt+1)-Thetar)
ELSE
Speed(Jpnt+1) = 0.0D0
END IF
Theta(Jpnt) = Thetar
Flux(Jpnt) = 0.0D0
Speed(Jpnt) = 0.0D0
Depth(Jpnt) = Dlength
Ltrail(Jpnt) = 0
Numwaves = Numwaves + 1
IF ( Numwaves.GT.NSFRSETS*NSTRAIL ) THEN
WRITE (*, *) 'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-1'
WRITE (IOUT, *)'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-1; INCREASE NSFRSETS'
STOP
END IF
ELSE
Depth(Jpnt) = Dlength
END IF
ELSE
dlength2 = Zoldist + 1.0D0
END IF
fm = 0.0D0
THETAB = Theta(Jpnt)
FLUXB = Flux(Jpnt)
Totalflux = 0.00D0
itester = 0
ffcheck = (Surflux-Flux(Jpnt+Numwaves-1))
C
C2------CREATE A NEW WAVE IF SURFACE FLUX CHANGES.
C CALL TRAILWAVE IF SURFACE FLUX DECREASES.
C CALL LEADWAVE IF SURFACE FLUX INCREASES.
IF ( DABS(ffcheck).GT.feps2 ) THEN
Numwaves = Numwaves + 1
IF ( Numwaves.GT.NSFRSETS*NSTRAIL ) THEN
WRITE (*, *) 'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-2'
WRITE (IOUT, *) 'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-2; INCREASE NSFRSETS'
STOP
END IF
ELSE IF ( Numwaves.EQ.1 ) THEN
itester = 1
END IF
IF ( Numwaves.GT.1 ) THEN
IF ( ffcheck.LT.-feps2 ) THEN
CALL TRAILWAVE(Numwaves, I, Flux, Theta, Speed, Depth,
+ Itrwave, Ltrail, Fksat, Eps, Thetas, Thetar,
+ Surflux, Jpnt)
itrailflg = 1
END IF
CALL LEADWAVE(Numwaves, time, Totalflux, itester, Flux,
+ Theta, Speed, Depth, Itrwave, Ltrail, Fksat,
+ Eps, Thetas, Thetar, Surflux, Oldsflx, Jpnt,
+ feps2, itrailflg, Deltinc)
END IF
IF ( itester.EQ.1 ) THEN
Totalflux = Totalflux + (Deltinc-time)*Flux(Jpnt)
time = 0.0D0
itester = 0
END IF
C
C3------CALCULATE VOLUME OF WATER IN UNSATURATED ZONE LOST WHEN
C WATER TABLE ROSE AND ADD AS RECHARGE TO GROUND WATER.
IF ( dlength2.LT.Zoldist ) THEN
j = 2
jj = 1
IF ( Depth(Jpnt+1).GT.dlength2 ) THEN
DO WHILE ( j.LE.Numwaves )
IF ( Depth(Jpnt+j-1).GE.dlength2 ) jj = j
IF ( j.EQ.jj .AND. Depth(Jpnt+j).LT.dlength2 ) j = Numwaves
j = j + 1
END DO
END IF
IF ( jj.GT.1 .AND. Numwaves.GT.1 ) THEN
fm = (Depth(Jpnt)-Depth(Jpnt+1))*(Theta(Jpnt)-Thetar)
DO j = 2, jj - 1
fm = fm + (Depth(Jpnt+j-1)-Depth(Jpnt+j))*(Theta(Jpnt+j-1)-
+ Thetar)
END DO
fm = fm+(Theta(Jpnt+jj-1)-Thetar)*(Depth(Jpnt+jj-1)-dlength2)
ELSE
fm = (Depth(Jpnt)-dlength2)*(Theta(Jpnt)-Thetar)
END IF
Dlength = dlength2
Totalflux = Totalflux + fm
IF ( Totalflux.LT.1.0D-30 ) Totalflux = 0.0D0
END IF
C4------RETURN.
RETURN
END SUBROUTINE UZFLOW
C
C
C-------SUBROUTINE LEADWAVE
SUBROUTINE LEADWAVE(Numwaves, Time, Totalflux, Itester, Flux,
+ Theta, Speed, Depth, Itrwave, Ltrail, Fksat,
+ Eps, Thetas, Thetar, Surflux, Oldsflx, Jpnt,
+ Feps2, Itrailflg, Deltinc)
C ******************************************************************
C CREATE LEAD WAVE WHEN THE SURFACE FLUX INCREASES AND ROUTE WAVES.
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
C
USE GWFSFRMODULE, ONLY: NSTOTRL, NEARZERO, CLOSEZERO, THETAB,
+ FLUXB, FLUXHLD2
C USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC ABS
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Itester, Jpnt, Numwaves, Itrailflg
INTEGER Itrwave(NSTOTRL), Ltrail(NSTOTRL)
REAL Fksat, Deltinc
DOUBLE PRECISION Depth(NSTOTRL), Theta(NSTOTRL), Flux(NSTOTRL),
+ Speed(NSTOTRL)
DOUBLE PRECISION Feps2, Totalflux, Surflux, Oldsflx, Thetar, Time
DOUBLE PRECISION Eps, Thetas
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION ffcheck, bottomtime, shortest, fcheck, fhold
DOUBLE PRECISION eps_m1, checktime(NSTOTRL), timenew, feps3
REAL big, comp1, comp2, diff, f7, f8, ftheta1, ftheta2
INTEGER idif, iflag, iflag2, iflx, iremove, itrwaveb, j, jj, k,
+ kk, l, jpnwavesm1, jpntpkm1, jpntpkm2, more(NSTOTRL)
C ------------------------------------------------------------------
C ADDED FEPS3 TO LIMIT CHANGES IN WATER CONTENT.
eps_m1 = Eps - 1.0D0
feps3 = 1.0D-07
f7 = 0.495
f8 = 1.0 - f7
big = 1.0E30
C
C1------INITIALIZE NEWEST WAVE.
IF ( Itrailflg.EQ.0 ) THEN
jpnwavesm1 = Jpnt + Numwaves - 1
ffcheck = Surflux - Oldsflx
IF ( ffcheck.GT.Feps2 ) THEN
Flux(jpnwavesm1) = Surflux
IF ( Flux(jpnwavesm1).LT.NEARZERO ) Flux(jpnwavesm1) = 0.0D0
Theta(jpnwavesm1) = (((Flux(jpnwavesm1)/Fksat)**(1.0D0/Eps))*
+ (Thetas-Thetar)) + Thetar
IF ( Theta(jpnwavesm1)-Theta(jpnwavesm1-1).GT.feps3 ) THEN
Speed(jpnwavesm1) = (Flux(jpnwavesm1)-Flux(jpnwavesm1-1))/
+ (Theta(jpnwavesm1)-Theta(jpnwavesm1-1))
Depth(jpnwavesm1) = 0.0D0
Ltrail(jpnwavesm1) = 0
Itrwave(jpnwavesm1) = 0
ELSE
Speed(jpnwavesm1) = 0.0D0
Numwaves = Numwaves - 1
END IF
END IF
END IF
C
C2------ROUTE ALL WAVES AND INTERCEPTION OF WAVES OVER TIME STEP.
diff = 1.0
iflx = 0
FLUXHLD2 = Flux(Jpnt)
IF ( Numwaves.EQ.0 ) Itester = 1
DO WHILE ( diff.GT.1.0E-7 .AND. Itester.NE.1 )
DO j = 1, Numwaves
checktime(j) = 0.0D0
more(j) = 0
END DO
j = 2
C
C3------CALCULATE TIME UNTIL A WAVE WILL OVERTAKE NEXT WAVE BELOW.
! RGN 1/25/08 broke up IF statement to make sure Itrwave(Jpnt+j) does not exceed bounds.
DO WHILE ( j.LE.Numwaves )
IF ( j.LT.Numwaves ) THEN
IF ( Ltrail(Jpnt+j-1).NE.0 .AND. Itrwave(Jpnt+j).GT.0 ) THEN
DO WHILE ( Ltrail(Jpnt+j-1).NE.0 .AND.
+ Itrwave(Jpnt+j).GT.0)
kk = j + Itrwave(Jpnt+j)
IF ( j.GT.2 .AND. ABS(Speed(Jpnt+j-2)-Speed(Jpnt+j-1))
+ .GT.CLOSEZERO ) THEN
checktime(j) = (Depth(Jpnt+j-1)-Depth(Jpnt+j-2))
+ /(Speed(Jpnt+j-2)-Speed(Jpnt+j-1))
ELSE
checktime(j) = big
END IF
IF ( Numwaves.GT.kk ) THEN
jj = j
j = j + Itrwave(Jpnt+j) + 1
C
C4------LEAD WAVE INTERSECTING TRAIL WAVE.
fhold = 0.0D0
IF ( ABS(Theta(Jpnt+jj-1)-Thetar).GT.CLOSEZERO )
+ fhold = (f7*Theta(Jpnt+j-2)+f8*Theta(Jpnt+j-3)-
+ Thetar)/(Theta(Jpnt+jj-1)-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
checktime(j) = (Depth(Jpnt+j-1)-Depth(Jpnt+jj-1)
+ *(fhold**eps_m1))/(Speed(Jpnt+jj-1)
+ *(fhold**eps_m1)-Speed(Jpnt+j-1))
ELSE
j = j + 1
END IF
END DO
ELSE IF ( ABS(Speed(Jpnt+j-2)-Speed(Jpnt+j-1)).GT.
+ CLOSEZERO .AND. j.NE.1 )THEN
checktime(j) = (Depth(Jpnt+j-1)-Depth(Jpnt+j-2))
+ /(Speed(Jpnt+j-2)-Speed(Jpnt+j-1))
ELSE
checktime(j) = big
END IF
ELSE IF ( ABS(Speed(Jpnt+j-2)-Speed(Jpnt+j-1)).GT.
+ CLOSEZERO .AND. j.NE.1 )THEN
checktime(j) = (Depth(Jpnt+j-1)-Depth(Jpnt+j-2))
+ /(Speed(Jpnt+j-2)-Speed(Jpnt+j-1))
ELSE
checktime(j) = big
END IF
j = j + 1
END DO
DO j = 2, Numwaves
IF ( checktime(j).LT.NEARZERO ) checktime(j) = big
END DO
C
C5------CALCULATE HOW LONG IT WILL TAKE BEFORE DEEPEST WAVE REACHES
C WATER TABLE.
IF ( Numwaves.GT.1 ) THEN
bottomtime = (Depth(Jpnt)-Depth(Jpnt+1))/Speed(Jpnt+1)
IF ( bottomtime.LE.0.0 ) bottomtime = 1.0D-12
ELSE
bottomtime = big
END IF
C
C6------CALCULATE SHORTEST TIME FOR WAVE INTERCEPTION.
shortest = Deltinc - Time
DO j = Numwaves, 3, -1
IF ( checktime(j).LE.shortest ) THEN
more(j) = 1
shortest = checktime(j)
DO k = j + 1, Numwaves
IF ( ABS(checktime(k)-checktime(j)).GT.CLOSEZERO )
+ more(k) = 0
END DO
END IF
END DO
IF ( Numwaves.EQ.2 ) shortest = Deltinc - Time
C
C7------CHECK IF DEEPEST WAVE REACHES WATER TABLE BEFORE WAVES
C INTERCEPT EACH OTHER.
iremove = 0
timenew = Time
fcheck = (Time+shortest) - Deltinc
IF ( shortest.LT.1.0E-7 ) fcheck = -1.0D0
IF ( bottomtime.LT.shortest .AND.
+ Time+bottomtime.LE.Deltinc ) THEN
j = 2
DO WHILE ( j.LE.Numwaves )
C
C8------ROUTE TRAIL WAVES.
IF ( Itrwave(Jpnt+j-1).EQ.0 ) THEN
Depth(Jpnt+j-1) = Depth(Jpnt+j-1) + Speed(Jpnt+j-1)
+ *bottomtime
ELSE
DO k = j, j + Itrwave(Jpnt+j-1) - 1
Cdep check to see if theta = thetar do not route?
IF(Theta(Jpnt+j-2)-Thetar.GT.CLOSEZERO) THEN
Depth(Jpnt+k-1) = Depth(Jpnt+j-2)*((f7*Theta(Jpnt+k-1)
+ +f8*Theta(Jpnt+k-2)-Thetar)
+ /(Theta(Jpnt+j-2)-Thetar))**eps_m1
END IF
END DO
j = j + Itrwave(Jpnt+j-1) - 1
END IF
j = j + 1
END DO
FLUXB = Flux(Jpnt+1)
THETAB = Theta(Jpnt+1)
iflx = 1
itrwaveb = Itrwave(Jpnt+2)
DO k = 2, Numwaves
jpntpkm1 = Jpnt + k - 1
jpntpkm2 = jpntpkm1 - 1
Flux(jpntpkm2) = Flux(jpntpkm1)
Theta(jpntpkm2) = Theta(jpntpkm1)
Speed(jpntpkm2) = Speed(jpntpkm1)
Depth(jpntpkm2) = Depth(jpntpkm1)
Itrwave(jpntpkm2) = Itrwave(jpntpkm1)
Ltrail(jpntpkm2) = Ltrail(jpntpkm1)
END DO
IF ( itrwaveb.EQ.1 ) THEN
Itrwave(Jpnt+1) = 0
Ltrail(Jpnt+1) = 1
fhold = (Theta(Jpnt+1)-Thetar)/(Thetas-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(Jpnt+1) = (Eps*Fksat/(Thetas-Thetar))*fhold**eps_m1
C
C9------MAKE ALL TRAIL WAVES LEAD TRAIL WAVES.
ELSE IF ( itrwaveb.GT.1 ) THEN
DO k = Jpnt + 1, Jpnt + itrwaveb
Itrwave(k) = 0
Ltrail(k) = 1
IF ( ABS(Theta(k)-Theta(k-1)).LT.CLOSEZERO ) THEN
fhold = ((Theta(k)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(k) = (Eps*Fksat/(Thetas-Thetar))*fhold**eps_m1
ELSE
fhold = ((Theta(k-1)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
ftheta1 = Fksat*fhold
fhold = ((Theta(k)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
ftheta2 = Fksat*fhold
Speed(k) = (ftheta1-ftheta2)/(Theta(k-1)-Theta(k))
END IF
END DO
END IF
iremove = 1
timenew = Time + bottomtime
Ltrail(Jpnt) = 0
Speed(Jpnt) = 0.0D0
C
C10-----CHECK IF WAVES INTERCEPT BEFORE TIME STEP ENDS.
ELSE IF ( fcheck.LT.0.0 .AND. Numwaves.GT.2 ) THEN
j = 2
DO WHILE ( j.LE.Numwaves )
IF ( Itrwave(Jpnt+j-1).EQ.0 ) THEN
Depth(Jpnt+j-1) = Depth(Jpnt+j-1) + Speed(Jpnt+j-1)
+ *shortest
ELSE
C
C11-----ROUTE TRAIL WAVES.
DO k = j, j + Itrwave(Jpnt+j-1) - 1
Cdep check to see if theta = thetar do not route?
IF(Theta(Jpnt+j-2)-Thetar.GT.CLOSEZERO) THEN
Depth(Jpnt+k-1) = Depth(Jpnt+j-2)*((f7*Theta(Jpnt+k-1)
+ +f8*Theta(Jpnt+k-2)-Thetar)
+ /(Theta(Jpnt+j-2)-Thetar))**eps_m1
END IF
END DO
j = j + Itrwave(Jpnt+j-1) - 1
END IF
j = j + 1
END DO
C
C12-----REMOVE WAVES THAT HAVE BEEN INTERCEPTED AND COMPUTE SPEED OF
C COMBINED WAVE.
j = 3
l = j
iflag = 0
DO WHILE ( iflag.EQ.0 )
IF ( more(j).EQ.1 ) THEN
l = j
IF ( Ltrail(Jpnt+j-1).NE.1 ) THEN
iflag2 = 0
k = j - 1
idif = 0
DO WHILE ( iflag2.EQ.0 )
IF ( Itrwave(Jpnt+k-1).GT.0 ) THEN
iflag2 = 1
idif = j - k
IF ( idif.EQ.Itrwave(Jpnt+k-1) )
+ Itrwave(Jpnt+k-1) = Itrwave(Jpnt+k-1) - 1
ELSE
k = k - 1
IF ( k.EQ.0 ) iflag2 = 1
END IF
END DO
IF ( j.EQ.3 ) THEN
comp1 = ABS(Theta(Jpnt+j-1)-THETAB)
comp2 = ABS(Flux(Jpnt+j-1)-FLUXB)
IF ( comp1.LE.1.E-9 ) Theta(Jpnt+j-1) = THETAB - 1.D-9
IF ( comp2.LE.1.E-15 ) Flux(Jpnt+j-1) = FLUXB - 1.D-15
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-FLUXB)
+ /(Theta(Jpnt+j-1)-THETAB)
ELSE
comp1 = ABS(Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
comp2 = ABS(Flux(Jpnt+j-1)-Flux(Jpnt+j-3))
IF ( comp1.LT.1.0E-9 ) Theta(Jpnt+j-1)
+ = Theta(Jpnt+j-3) - 1.0D-9
IF ( comp2.LT.1.0E-15 ) Flux(Jpnt+j-1)
+ = Flux(Jpnt+j-3) - 1.0D-15
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-Flux(Jpnt+j-3))/
+ (Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
END IF
ELSE IF ( Itrwave(Jpnt+j).GT.0 ) THEN
IF ( ABS(Speed(Jpnt+j-2)).GT.CLOSEZERO ) THEN
C
C13-----CONVERT TRAIL WAVES TO LEAD TRAIL WAVES WHEN LEAD TRAIL
C WAVE INTERSECTS A LEAD WAVE.
DO k = Jpnt + j, Jpnt + j + Itrwave(Jpnt+j) - 1
Ltrail(k) = 1
Itrwave(k) = 0
IF ( ABS(Theta(k)-Theta(k-1)).LT.CLOSEZERO ) THEN
fhold = ((Theta(k)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(k) = (Eps*Fksat/(Thetas-Thetar))*fhold
+ **eps_m1
ELSE
fhold = ((Theta(k-1)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
ftheta1 = Fksat*fhold
fhold = ((Theta(k)-Thetar)/(Thetas-Thetar))**Eps
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
ftheta2 = Fksat*fhold
Speed(k) = (ftheta1-ftheta2)/(Theta(k-1)-Theta(k))
END IF
END DO
Ltrail(Jpnt+j-1) = 0
IF ( j.EQ.3 ) THEN
C
C14-----RECALCULATE FLUX.
comp1 = ABS(Theta(Jpnt+j-1)-THETAB)
comp2 = ABS(Flux(Jpnt+j-1)-FLUXB)
IF (comp1.LE.1.E-9) Theta(Jpnt+j-1) = THETAB - 1.D-9
IF (comp2.LE.1.E-15) Flux(Jpnt+j-1) = FLUXB - 1.D-15
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-FLUXB)
+ /(Theta(Jpnt+j-1)-THETAB)
IF ( Flux(Jpnt+j-1)-FLUXB.LT.0.0D0 ) THEN
fhold = (Theta(Jpnt+j-1)-Thetar)/(Thetas-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(Jpnt+j-1) = ((Eps*Fksat)/(Thetas-Thetar))
+ *fhold**eps_m1
Ltrail(Jpnt+j-1) = 1
ELSE
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-FLUXB)
+ /(Theta(Jpnt+j-1)-THETAB)
END IF
ELSE
comp1 = ABS(Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
comp2 = ABS(Flux(Jpnt+j-1)-Flux(Jpnt+j-3))
IF ( comp1.LT.1.0E-9 ) Theta(Jpnt+j-1)
+ = Theta(Jpnt+j-3) - 1.0D-9
IF ( comp2.LT.1.0E-15 ) Flux(Jpnt+j-1)
+ = Flux(Jpnt+j-3) - 1.0D-15
IF ( Flux(Jpnt+j-1)-Flux(Jpnt+j-3).LT.0.0D0 ) THEN
fhold = (Theta(Jpnt+j-1)-Thetar)/(Thetas-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(Jpnt+j-1) = ((Eps*Fksat)/(Thetas-Thetar))
+ *fhold**eps_m1
Ltrail(Jpnt+j-1) = 1
ELSE
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-Flux(Jpnt+j-3))
+ /(Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
END IF
END IF
END IF
iflag2 = 0
k = j - 1
idif = 0
DO WHILE ( iflag2.EQ.0 )
IF ( Itrwave(Jpnt+k-1).GT.0 ) THEN
iflag2 = 1
idif = j - k
IF ( idif.EQ.Itrwave(Jpnt+k-1) )
+ Itrwave(Jpnt+k-1) = Itrwave(Jpnt+k-1) - 1
ELSE
k = k - 1
IF ( k.EQ.0 ) iflag2 = 1
END IF
END DO
j = j + Itrwave(Jpnt+j+1) + 2
ELSE
Ltrail(Jpnt+j-1) = 0
Itrwave(Jpnt+j) = 0
IF ( j.EQ.3 ) THEN
comp1 = ABS(Theta(Jpnt+j-1)-THETAB)
comp2 = ABS(Flux(Jpnt+j-1)-FLUXB)
IF ( comp1.LE.1.E-9 ) Theta(Jpnt+j-1) = THETAB - 1.D-9
IF ( comp2.LE.1.E-15 ) Flux(Jpnt+j-1) = FLUXB - 1.D-15
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-FLUXB)
+ /(Theta(Jpnt+j-1)-THETAB)
ELSE
comp1 = ABS(Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
comp2 = ABS(Flux(Jpnt+j-1)-Flux(Jpnt+j-3))
IF ( comp1.LT.1.0E-9 ) Theta(Jpnt+j-1)
+ = Theta(Jpnt+j-3) - 1.0D-9
IF ( comp2.LT.1.0E-15 ) Flux(Jpnt+j-1)
+ = Flux(Jpnt+j-3) - 1.0D-15
Speed(Jpnt+j-1) = (Flux(Jpnt+j-1)-Flux(Jpnt+j-3))/
+ (Theta(Jpnt+j-1)-Theta(Jpnt+j-3))
END IF
iflag2 = 0
k = j - 1
idif = 0
DO WHILE ( iflag2.EQ.0 )
IF ( Itrwave(Jpnt+k-1).GT.0 ) THEN
iflag2 = 1
idif = j - k
IF ( idif.EQ.Itrwave(Jpnt+k-1) ) THEN
Itrwave(Jpnt+k-1) = Itrwave(Jpnt+k-1) - 1
IF ( Theta(Jpnt+j-1).LE.Theta(Jpnt+j-3) ) THEN
Ltrail(Jpnt+j-1) = 1
fhold = (Theta(Jpnt+j-1)-Thetar)/(Thetas-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(Jpnt+j-1) = ((Eps*Fksat)/(Thetas-Thetar))
+ *fhold**eps_m1
END IF
END IF
ELSE
k = k - 1
IF ( k.EQ.0 ) iflag2 = 1
END IF
END DO
END IF
DO k = l, Numwaves
jpntpkm1 = Jpnt + k - 1
jpntpkm2 = jpntpkm1 - 1
Flux(jpntpkm2) = Flux(jpntpkm1)
Theta(jpntpkm2) = Theta(jpntpkm1)
Speed(jpntpkm2) = Speed(jpntpkm1)
Depth(jpntpkm2) = Depth(jpntpkm1)
Itrwave(jpntpkm2) = Itrwave(jpntpkm1)
Ltrail(jpntpkm2) = Ltrail(jpntpkm1)
END DO
l = Numwaves + 1
iremove = iremove + 1
ELSE IF ( Itrwave(Jpnt+j-1).GT.0 ) THEN
j = j + Itrwave(Jpnt+j-1) - 1
END IF
j = j + 1
IF ( j.GT.Numwaves ) iflag = 1
END DO
timenew = timenew + shortest
C
C15-----CALCULATE TOTAL FLUX TO WATER TABLE DURING REMAINING TIME IN
C STEP.
ELSE
j = 2
DO WHILE ( j.LE.Numwaves )
IF ( Itrwave(Jpnt+j-1).EQ.0 ) THEN
Depth(Jpnt+j-1) = Depth(Jpnt+j-1) + Speed(Jpnt+j-1)
+ *(Deltinc-Time)
ELSE
C
C16-----ROUTE TRAIL WAVES.
DO k = j, j + Itrwave(Jpnt+j-1) - 1
Cdep check to see if theta = thetar do not route?
IF(Theta(Jpnt+j-2)-Thetar.GT.CLOSEZERO) THEN
Depth(Jpnt+k-1) = Depth(Jpnt+j-2)*((f7*Theta(Jpnt+k-1)
+ +f8*Theta(Jpnt+k-2)-Thetar)
+ /(Theta(Jpnt+j-2)-Thetar))**eps_m1
END IF
END DO
j = j + Itrwave(Jpnt+j-1) - 1
END IF
j = j + 1
END DO
timenew = Deltinc
END IF
Totalflux = Totalflux + FLUXHLD2*(timenew-Time)
IF ( iflx.EQ.1 ) THEN
FLUXHLD2 = Flux(Jpnt)
iflx = 0
END IF
C17-----REMOVE ARRAY ELEMENTS RESULTING FROM INTERCEPTED WAVES.
Numwaves = Numwaves - iremove
Time = timenew
diff = Deltinc - Time
IF ( Numwaves.EQ.1 ) Itester = 1
END DO
C18-----RETURN.
RETURN
END SUBROUTINE LEADWAVE
C
C-------SUBROUTINE TRAILWAVE
SUBROUTINE TRAILWAVE(Numwaves, I, Flux, Theta, Speed, Depth,
+ Itrwave, Ltrail, Fksat, Eps, Thetas, Thetar,
+ Surflux, Jpnt)
C ******************************************************************
C INITIALIZE A NEW SET OF TRAIL WAVES WHEN SURFACE FLUX DECREASES.
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NSTOTRL, NSTRAIL, NSFRSETS, NEARZERO,
+ FLUXHLD2, FLUXB, THETAB
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
INTRINSIC FLOAT
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
REAL Fksat
INTEGER Numwaves, I, Jpnt, Itrwave(NSTOTRL), Ltrail(NSTOTRL)
DOUBLE PRECISION Speed(NSTOTRL), Flux(NSTOTRL), Depth(NSTOTRL),
+ Theta(NSTOTRL), Surflux, Thetar, Thetas, Eps
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
DOUBLE PRECISION smoist, smoistinc, ftrail, fhold, eps_m1
REAL fnuminc
INTEGER j, jj, jk, kk, numtrail2, jpnwavesm1, jpnwavesm2, jpntpjm1
C ------------------------------------------------------------------
eps_m1 = Eps - 1.0D0
THETAB = Theta(Jpnt)
FLUXB = Flux(Jpnt)
numtrail2 = NSTRAIL
jpnwavesm1 = Jpnt + Numwaves - 1
jpnwavesm2 = jpnwavesm1 - 1
C1------INITIALIZE TRAIL WAVES WHEN SURFACE FLUX DECREASES.
kk = 1
FLUXHLD2 = Flux(Jpnt)
IF ( Surflux.LT.NEARZERO ) Surflux = 0.0D0
smoist = (((Surflux/Fksat)**(1.0D0/Eps))*(Thetas-Thetar)) + Thetar
IF ( Theta(jpnwavesm2)-smoist.GT.1.0D-6 ) THEN
fnuminc = 0.0
DO jk = 1, NSTRAIL
fnuminc = fnuminc + FLOAT(jk)
END DO
smoistinc = (Theta(jpnwavesm2)-smoist)/(fnuminc-1.0)
jj = NSTRAIL
ftrail = NSTRAIL + 1
DO j = Numwaves, Numwaves + numtrail2 - 1
IF ( j.GT.NSTOTRL ) THEN
WRITE (*, *) 'TOO MANY WAVES IN UNSAT CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN TRAILWAVE SFR2'
WRITE (IOUT, *) 'TOO MANY WAVES IN UNSAT CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN TRAILWAVE SFR2; INCREASE NSFRSETS'
STOP
END IF
jpntpjm1 = Jpnt + j - 1
Ltrail(jpntpjm1) = 0
Itrwave(jpntpjm1) = 0
IF ( j.GT.Numwaves ) THEN
Theta(jpntpjm1) = Theta(Jpnt+j-2)
+ - ((ftrail-FLOAT(jj))*smoistinc)
ELSE
Theta(jpntpjm1) = Theta(Jpnt+j-2) - 1.0D-8
END IF
jj = jj - 1
IF ( Theta(jpntpjm1).LE.Thetar+1.0D-6 ) Theta(jpntpjm1)
+ = Thetar + 1.0D-6
Flux(jpntpjm1) = Fksat*((Theta(jpntpjm1)-Thetar)
+ /(Thetas-Thetar))**Eps
IF ( j.EQ.Numwaves ) THEN
fhold = (Theta(jpntpjm1)-Thetar)/(Thetas-Thetar)
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(jpntpjm1) = ((Eps*Fksat)/(Thetas-Thetar))*fhold
+ **eps_m1
ELSE
Speed(jpntpjm1) = 0.0D0
END IF
kk = kk + 1
Depth(jpntpjm1) = 0.0D0
END DO
Itrwave(Jpnt+Numwaves) = numtrail2 - 1
Ltrail(jpnwavesm1) = 1
Numwaves = Numwaves + numtrail2 - 1
IF ( Numwaves.GT.NSFRSETS*NSTRAIL ) THEN
WRITE (*, *) 'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-4'
WRITE (IOUT, *)'TOO MANY WAVES IN STREAM CELL', I, Numwaves,
+ ' PROGRAM TERMINATED IN UZFLOW-4; INCREASE NSFRSETS'
STOP
END IF
ELSE
Ltrail(jpnwavesm1) = 1
Theta(jpnwavesm1) = Theta(jpnwavesm2)
fhold = (Theta(jpnwavesm1)-Thetar)/(Thetas-Thetar)
Depth(jpnwavesm1) = 0.0D0
IF ( fhold.LT.NEARZERO ) fhold = 0.0D0
Speed(jpnwavesm1) = ((Eps*Fksat)/(Thetas-Thetar))*fhold**eps_m1
Flux(jpnwavesm1) = Fksat*((Theta(jpnwavesm1)-Thetar)
+ /(Thetas-Thetar))**Eps
END IF
C
C2------RETURN.
RETURN
END SUBROUTINE TRAILWAVE
C
C-------SUBROUTINE CHANNELAREA
SUBROUTINE CHANNELAREA(Istsg, L)
C ******************************************************************
C COMPARTMENTALIZE UNSATURATED ZONE BENEATH STREAMBED ON BASIS OF
C EIGHT POINT CROSS SECTION WHEN ICALC IS 2
C VERSION 7.1.01: February 15, 2009
C ******************************************************************
USE GWFSFRMODULE, ONLY: NUZST, ISUZN, XSEC, WETPER
IMPLICIT NONE
INTRINSIC ABS, SQRT
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Istsg, L
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
REAL area, area1, b, chap, ffmax, ffmin, finc, fmax, fmin, slope,
+ stage, wethold, wetted, xinc, xmid, xx, y1, y2, yy
INTEGER i, ii, j, k, ll, mark(20)
DOUBLE PRECISION dpthinc
ALLOCATABLE dpthinc(:,:)
ALLOCATE (dpthinc(ISUZN,NUZST))
C ------------------------------------------------------------------
area = 0.0
area1 = 0.0
wethold = 0.0
wetted = 0.0
C
C1------CALCULATE THE MAXIMUM AND MINIMUM CHANNEL ELEVATIONS.
C
fmin = XSEC(9, Istsg)
fmax = XSEC(9, Istsg)
DO i = 2, 8
IF ( XSEC(8+i, Istsg).LT.fmin ) fmin = XSEC(8+i, Istsg)
IF ( XSEC(8+i, Istsg).GT.fmax ) fmax = XSEC(8+i, Istsg)
END DO
finc = (fmax-fmin)/ISUZN
DO i = 1, ISUZN
dpthinc(i, L) = i*finc
END DO
C
C2------CALCULATE WETTED PERIMETERS FOR INCREMENTAL RIVER DEPTHS.
DO i = 1, ISUZN
stage = dpthinc(i, L)
area = 0.0
wetted = 0.0
C
C3------DETERMINE POINTS THAT ARE BELOW STREAM STAGE.
k = 0
DO j = 2, 8
IF ( XSEC(8+j, Istsg).LT.stage .OR. XSEC(8+j-1, Istsg)
+ .LT.stage ) THEN
k = k + 1
mark(k) = j
END IF
END DO
C
C4------BREAK CHANNEL UP INTO A SERIES OF LINES BETWEEN POINTS
C AND CALCULATE EQUATION OF EACH LINE.
DO ll = 1, k
chap = (XSEC(8+mark(ll)-1, Istsg)-XSEC(8+mark(ll), Istsg))
IF ( ABS(XSEC(8+mark(ll), Istsg)-XSEC(8+mark(ll)-1, Istsg))
+ .LT.1.0E-30.AND.ABS(XSEC(mark(ll), Istsg)-
+ XSEC(mark(ll)-1, Istsg)).LT.1.0E-30 )THEN
WRITE (*, *) 'two cross-section points are identical,',
+ ' check input. Segment number ', Istsg
slope = 0.0 !rsr, slope needs a value
ELSE IF ( ABS(XSEC(8+mark(ll), Istsg)-
+ XSEC(8+mark(ll)-1, Istsg)).LT.1.0E-30) THEN
slope = 1.0E-5
ELSE IF ( ABS(XSEC(mark(ll), Istsg)-XSEC(mark(ll)-1, Istsg))
+ .LT.1.0E-30 )THEN
slope = 10.0
ELSE
slope = (XSEC(8+mark(ll), Istsg)-XSEC(8+mark(ll)-1, Istsg))
+ /(XSEC(mark(ll), Istsg)-XSEC(mark(ll)-1, Istsg))
END IF
ffmin = XSEC(8+mark(ll), Istsg)
ffmax = XSEC(8+mark(ll)-1, Istsg)
IF ( ffmin.GT.ffmax ) THEN
ffmin = XSEC(8+mark(ll)-1, Istsg)
ffmax = XSEC(8+mark(ll), Istsg)
END IF
b = XSEC(8+mark(ll)-1, Istsg) - slope*XSEC(mark(ll)-1, Istsg)
C
C5------WETTED AREA ASSUMING A FLAT CHANNEL BOTTOM.
IF ( ABS(chap).LT.1.0E-30 ) THEN
area1 = (XSEC(mark(ll), Istsg)-XSEC(mark(ll)-1, Istsg))
+ *(stage-ffmin)
ELSE
C
C6------DETERMINE IF STREAM STAGE IS BETWEEN POINTS.
IF ( stage.GT.ffmax ) THEN
xinc = (XSEC(mark(ll), Istsg)-XSEC(mark(ll)-1, Istsg))/50.
xmid = XSEC(mark(ll)-1, Istsg)
ELSE
ffmax = stage
xmid = (stage-b)/slope
C
C7------MOVE DOWN THE CHANNEL BANK OR UP OTHER SIDE.
IF ( XSEC(8+mark(ll)-1, Istsg).LT.XSEC(8+mark(ll), Istsg)
+ ) THEN
xinc = (ABS(XSEC(mark(ll)-1,Istsg)-xmid))/50.
xmid = XSEC(mark(ll)-1, Istsg)
ELSE
xinc = (ABS(XSEC(mark(ll),Istsg)-xmid))/50.
END IF
END IF
C8------CALCULATE WETTED PARIMETER.
xx = ABS(xmid-XSEC(mark(ll), Istsg))
yy = ABS(ffmax-ffmin)
wetted = wetted + SQRT((xx**2)+(yy**2))
C9------BREAK AREA UP INTO TRAPAZOIDS.
DO ii = 1, 50
y1 = slope*xmid + b
y2 = slope*(xmid+xinc) + b
area = area + (((stage-y1)+(stage-y2))/2)*xinc
xmid = xmid + xinc
END DO
END IF
END DO
area = area + area1
IF ( i.EQ.1 ) THEN
WETPER(i, L) = wetted
ELSE
WETPER(i, L) = (wetted-wethold)
END IF
wethold = wetted
END DO
DEALLOCATE (dpthinc)
C
C10-----RETURN.
RETURN
END SUBROUTINE CHANNELAREA
C
C-------SUBROUTINE ROUTE_CHAN
SUBROUTINE ROUTE_CHAN(Qa, Qb, Qc, Qd, Qcnst, Cdpth, Awdth, Fdpth,
+ Bwdth, Deltinc, Icalc, Strlen, Slope, Istsg,
+ Nreach, Itstr, Qlat, Flobot, Width, L,
+ Chanstor)
C***********************************************************************
C IMPLICIT FINITE-DIFFERENCE SCHEME TO ROUTE FLOW DOWN CHANNELS
C VERSION 7.1.01: February 15, 2009
C***********************************************************************
USE GWFSFRMODULE, ONLY: ISEG, WEIGHT, SEG, FLWTOL, NEARZERO
USE GLOBAL, ONLY: IOUT
IMPLICIT NONE
C ------------------------------------------------------------------
C SPECIFICATIONS:
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER Icalc, Istsg, Nreach, L, Itstr
DOUBLE PRECISION Flobot, Slope, Cdpth, Fdpth, Width, Qa, Qb, Qc,
+ Qd, Awdth, Bwdth
REAL Qcnst, Strlen, Deltinc, Qlat, Chanstor
INTRINSIC ABS, DABS
C ------------------------------------------------------------------
C LOCAL VARIABLES
C ------------------------------------------------------------------
INTEGER i, maxiter, iprndpth
REAL w_1, stor
DOUBLE PRECISION qderiv, dq, delq, flobot2, tol, ab, ac, aa, ad1
DOUBLE PRECISION wetperm, depth, qd2, qd3, f11, f12, f1, f2, ad2
C ------------------------------------------------------------------
iprndpth = 0
maxiter = 200
w_1 = 1.0 - WEIGHT
dq = FLWTOL/10.0
tol = FLWTOL
IF ( dq.LT.NEARZERO ) dq = NEARZERO
IF ( tol.LT.NEARZERO ) tol = NEARZERO
i = 1
IF ( Flobot.GT.Qc+Qlat*Strlen ) THEN
Flobot = Qc+Qlat*Strlen
END IF
C
C1------CHANGE SIGN OF FLOBOT BECAUSE IT IS A DISCHARGE FROM GROUND
C WATER AND IS STORED AS A NEGATIVE VALUE.
flobot2 = -Flobot/Strlen
C
C2------MAKE AN INITIAL GUESS AT Qd.
Qd = (Qc+Qb)/2.0
C
C3------INITIALIZE CONSTANTS.
delq = 0.0D0
IF ( Icalc.EQ.1 ) THEN
aa = Width*(Qa/Qcnst)**0.6D0
ab = Width*(Qb/Qcnst)**0.6D0
ac = Width*(Qc/Qcnst)**0.6D0
ELSE IF ( Icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(Qa, Slope, Istsg, Nreach, SEG(16,Istsg),
+ SEG(17,Istsg), wetperm, depth, Itstr, Width,
+ iprndpth)
aa = depth*Width
CALL GWF2SFR7DPTH(Qb, Slope, Istsg, Nreach, SEG(16,Istsg),
+ SEG(17,Istsg), wetperm, depth, Itstr, Width,
+ iprndpth)
ab = depth*Width
CALL GWF2SFR7DPTH(Qc, Slope, Istsg, Nreach, SEG(16,Istsg),
+ SEG(17,Istsg), wetperm, depth, Itstr,
+ Width, iprndpth)
ac = depth*Width
ELSE IF ( Icalc.EQ.3 ) THEN
depth = Cdpth*(Qa**Fdpth)
Width = Awdth*(Qa**Bwdth)
aa = depth*Width
depth = Cdpth*(Qb**Fdpth)
Width = Awdth*(Qb**Bwdth)
ab = depth*Width
depth = Cdpth*(Qc**Fdpth)
Width = Awdth*(Qc**Bwdth)
ac = depth*Width
ELSE IF ( Icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(Qa, depth, Width, ISEG(2,Istsg), Istsg)
aa = depth*Width
CALL GWF2SFR7TBD(Qb, depth, Width, ISEG(2,Istsg), Istsg)
ab = depth*Width
CALL GWF2SFR7TBD(Qc, depth, Width, ISEG(2,Istsg), Istsg)
ac = depth*Width
END IF
C
C4------CALCULATE FLOW IN CHANNELS--MAXIMUM ITERATIONS IS 50.
CONVERGE: DO WHILE( i.LT.maxiter )
C
C5------LOOP THROUGH UNTIL delq LESS THAN TOLERANCE.
IF ( DABS(delq).GT.tol .OR. i.EQ.1 ) THEN
qd2 = Qd + dq
qd3 = Qd + 2.0*dq
C
C6------CALCULATE VARIABLES ad1 and ad2 ON BASIS OF Icalc.
IF ( Icalc.EQ.1 ) THEN
depth = (Qd/Qcnst)**0.6D0
ad1 = depth*Width
depth = (qd2/Qcnst)**0.6D0
ad2 = depth*Width
ELSE IF ( Icalc.EQ.2 ) THEN
CALL GWF2SFR7DPTH(Qd, Slope, Istsg, Nreach, SEG(16,Istsg),
+ SEG(17,Istsg), wetperm, depth, Itstr,
+ Width, iprndpth)
ad1 = depth*Width
CALL GWF2SFR7DPTH(qd2, Slope, Istsg, Nreach, SEG(16,Istsg),
+ SEG(17,Istsg), wetperm, depth, Itstr,
+ Width, iprndpth)
ad2 = depth*Width
ELSE IF ( Icalc.EQ.3 ) THEN
depth = Cdpth*(Qd**Fdpth)
Width = Awdth*(Qd**Bwdth)
ad1 = depth*Width
depth = Cdpth*(qd2**Fdpth)
Width = Awdth*(qd2**Bwdth)
ad2 = depth*Width
depth = Cdpth*(qd3**Fdpth)
Width = Awdth*(qd3**Bwdth)
ELSE IF ( Icalc.EQ.4 ) THEN
CALL GWF2SFR7TBD(Qd, depth, Width, ISEG(2,Istsg), Istsg)
ad1 = depth*Width
CALL GWF2SFR7TBD(qd2, depth, Width, ISEG(2,Istsg), Istsg)
ad2 = depth*Width
CALL GWF2SFR7TBD(qd3, depth, Width, ISEG(2,Istsg), Istsg)
END IF
C
C7------CALCULATE FLOW.
IF ( (Qb+Qa).LT.NEARZERO ) THEN
f11 = (Qd-Qc)/Strlen
ELSE
f11 = (WEIGHT*((Qd)-Qc)+(w_1)*(Qb-Qa))/Strlen
END IF
f12 = ((ad1-ab)+(ac-aa))/(2.0D0*Deltinc)
f1 = f11+f12-Qlat-flobot2
IF ( (Qb+Qa).LT.NEARZERO ) THEN
f11 = (Qd+dq-Qc)/Strlen
ELSE
f11 = (WEIGHT*((Qd+dq)-Qc)+(w_1)*(Qb-Qa))/Strlen
END IF
f12 = ((ad2-ab)+(ac-aa))/(2.0D0*Deltinc)
f2 = f11+f12-Qlat-flobot2
qderiv = (f2-f1)/dq
delq = -f1/qderiv
IF ( (Qd + delq).LT.NEARZERO ) THEN
delq = -Qd
Qd = 0.0D0
ELSE
Qd = Qd + delq
END IF
C
C8------EXIT LOOP IF delq LESS THAN TOLERANCE.
ELSE
EXIT CONVERGE
END IF
i = i + 1
END DO CONVERGE
stor = Strlen*(ad2+ac)/(2.0D0*Deltinc) -
+ Strlen*(ab+aa)/(2.0D0*Deltinc)
Chanstor = Qc - Qd - stor - FLOBOT
IF ( i.GE.maxiter ) WRITE(IOUT,*) 'Non-convergence in ROUTE_CHAN',
+ L, delq
IF ( Qd.LT.tol ) tol = 0.0D0
C
C9------RETURN.
RETURN
END SUBROUTINE ROUTE_CHAN
C
C-------SUBROUTINE GWF2SFR7DA
SUBROUTINE GWF2SFR7DA(IGRID)
C Save SFR data for a grid.
USE GWFSFRMODULE
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER IGRID
C ------------------------------------------------------------------
DEALLOCATE (GWFSFRDAT(IGRID)%NSS)
DEALLOCATE (GWFSFRDAT(IGRID)%NSTRM)
DEALLOCATE (GWFSFRDAT(IGRID)%NSFRPAR)
DEALLOCATE (GWFSFRDAT(IGRID)%ISTCB1)
DEALLOCATE (GWFSFRDAT(IGRID)%ISTCB2)
DEALLOCATE (GWFSFRDAT(IGRID)%IUZT)
DEALLOCATE (GWFSFRDAT(IGRID)%MAXPTS)
DEALLOCATE (GWFSFRDAT(IGRID)%ISFROPT)
DEALLOCATE (GWFSFRDAT(IGRID)%NSTRAIL)
DEALLOCATE (GWFSFRDAT(IGRID)%ISUZN)
DEALLOCATE (GWFSFRDAT(IGRID)%NSFRSETS)
DEALLOCATE (GWFSFRDAT(IGRID)%NUZST)
DEALLOCATE (GWFSFRDAT(IGRID)%NSTOTRL)
DEALLOCATE (GWFSFRDAT(IGRID)%NUMAVE)
DEALLOCATE (GWFSFRDAT(IGRID)%ITMP)
DEALLOCATE (GWFSFRDAT(IGRID)%IRDFLG)
DEALLOCATE (GWFSFRDAT(IGRID)%IPTFLG)
DEALLOCATE (GWFSFRDAT(IGRID)%NUMTIM)
DEALLOCATE (GWFSFRDAT(IGRID)%WEIGHT)
DEALLOCATE (GWFSFRDAT(IGRID)%SFRRATIN)
DEALLOCATE (GWFSFRDAT(IGRID)%SFRRATOUT)
DEALLOCATE (GWFSFRDAT(IGRID)%FLWTOL)
DEALLOCATE (GWFSFRDAT(IGRID)%IRTFLG)
DEALLOCATE (GWFSFRDAT(IGRID)%NP)
DEALLOCATE (GWFSFRDAT(IGRID)%CONST)
DEALLOCATE (GWFSFRDAT(IGRID)%DLEAK)
DEALLOCATE (GWFSFRDAT(IGRID)%IOTSG)
DEALLOCATE (GWFSFRDAT(IGRID)%NSEGCK)
DEALLOCATE (GWFSFRDAT(IGRID)%ITRLSTH)
DEALLOCATE (GWFSFRDAT(IGRID)%ISEG)
DEALLOCATE (GWFSFRDAT(IGRID)%IDIVAR)
DEALLOCATE (GWFSFRDAT(IGRID)%ISTRM)
DEALLOCATE (GWFSFRDAT(IGRID)%LTRLIT)
DEALLOCATE (GWFSFRDAT(IGRID)%LTRLST)
DEALLOCATE (GWFSFRDAT(IGRID)%ITRLIT)
DEALLOCATE (GWFSFRDAT(IGRID)%ITRLST)
DEALLOCATE (GWFSFRDAT(IGRID)%NWAVST)
DEALLOCATE (GWFSFRDAT(IGRID)%STRIN)
DEALLOCATE (GWFSFRDAT(IGRID)%STROUT)
DEALLOCATE (GWFSFRDAT(IGRID)%FXLKOT)
DEALLOCATE (GWFSFRDAT(IGRID)%UHC)
DEALLOCATE (GWFSFRDAT(IGRID)%SGOTFLW)
DEALLOCATE (GWFSFRDAT(IGRID)%DVRSFLW)
DEALLOCATE (GWFSFRDAT(IGRID)%SFRUZBD)
DEALLOCATE (GWFSFRDAT(IGRID)%SEG)
DEALLOCATE (GWFSFRDAT(IGRID)%STRM)
DEALLOCATE (GWFSFRDAT(IGRID)%HSTRM)
DEALLOCATE (GWFSFRDAT(IGRID)%QSTRM)
DEALLOCATE (GWFSFRDAT(IGRID)%SLKOTFLW)
DEALLOCATE (GWFSFRDAT(IGRID)%DLKOTFLW)
DEALLOCATE (GWFSFRDAT(IGRID)%DLKSTAGE)
DEALLOCATE (GWFSFRDAT(IGRID)%HWDTH)
DEALLOCATE (GWFSFRDAT(IGRID)%HWTPRM)
DEALLOCATE (GWFSFRDAT(IGRID)%SFRQ)
DEALLOCATE (GWFSFRDAT(IGRID)%QSTAGE)
DEALLOCATE (GWFSFRDAT(IGRID)%XSEC)
DEALLOCATE (GWFSFRDAT(IGRID)%AVDPT)
DEALLOCATE (GWFSFRDAT(IGRID)%AVWAT)
DEALLOCATE (GWFSFRDAT(IGRID)%WAT1)
DEALLOCATE (GWFSFRDAT(IGRID)%CONCQ)
DEALLOCATE (GWFSFRDAT(IGRID)%CONCRUN)
DEALLOCATE (GWFSFRDAT(IGRID)%CONCPPT)
DEALLOCATE (GWFSFRDAT(IGRID)%THTS)
DEALLOCATE (GWFSFRDAT(IGRID)%THTR)
DEALLOCATE (GWFSFRDAT(IGRID)%EPS)
DEALLOCATE (GWFSFRDAT(IGRID)%FOLDFLBT)
DEALLOCATE (GWFSFRDAT(IGRID)%THTI)
DEALLOCATE (GWFSFRDAT(IGRID)%UZFLWT)
DEALLOCATE (GWFSFRDAT(IGRID)%UZSTOR)
DEALLOCATE (GWFSFRDAT(IGRID)%UZWDTH)
DEALLOCATE (GWFSFRDAT(IGRID)%UZSEEP)
DEALLOCATE (GWFSFRDAT(IGRID)%DELSTOR)
DEALLOCATE (GWFSFRDAT(IGRID)%WETPER)
DEALLOCATE (GWFSFRDAT(IGRID)%UZDPIT)
DEALLOCATE (GWFSFRDAT(IGRID)%UZDPST)
DEALLOCATE (GWFSFRDAT(IGRID)%UZTHIT)
DEALLOCATE (GWFSFRDAT(IGRID)%UZTHST)
DEALLOCATE (GWFSFRDAT(IGRID)%UZSPIT)
DEALLOCATE (GWFSFRDAT(IGRID)%UZSPST)
DEALLOCATE (GWFSFRDAT(IGRID)%UZFLIT)
DEALLOCATE (GWFSFRDAT(IGRID)%UZFLST)
DEALLOCATE (GWFSFRDAT(IGRID)%UZOLSFLX)
DEALLOCATE (GWFSFRDAT(IGRID)%SUMRCH)
DEALLOCATE (GWFSFRDAT(IGRID)%SUMLEAK)
DEALLOCATE (GWFSFRDAT(IGRID)%HLDSFR)
DEALLOCATE (GWFSFRDAT(IGRID)%STRMDELSTOR_CUM)
DEALLOCATE (GWFSFRDAT(IGRID)%STRMDELSTOR_RATE)
DEALLOCATE (GWFSFRDAT(IGRID)%TOTSPFLOW)
C
END SUBROUTINE GWF2SFR7DA
C
C-------SUBROUTINE GWF2SFR7PNT
SUBROUTINE SGWF2SFR7PNT(IGRID)
C Change SFR data to a different grid.
USE GWFSFRMODULE
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER IGRID
C ------------------------------------------------------------------
NSS=>GWFSFRDAT(IGRID)%NSS
NSTRM=>GWFSFRDAT(IGRID)%NSTRM
NSFRPAR=>GWFSFRDAT(IGRID)%NSFRPAR
ISTCB1=>GWFSFRDAT(IGRID)%ISTCB1
ISTCB2=>GWFSFRDAT(IGRID)%ISTCB2
IUZT=>GWFSFRDAT(IGRID)%IUZT
MAXPTS=>GWFSFRDAT(IGRID)%MAXPTS
ISFROPT=>GWFSFRDAT(IGRID)%ISFROPT
NSTRAIL=>GWFSFRDAT(IGRID)%NSTRAIL
ISUZN=>GWFSFRDAT(IGRID)%ISUZN
NSFRSETS=>GWFSFRDAT(IGRID)%NSFRSETS
NUZST=>GWFSFRDAT(IGRID)%NUZST
NSTOTRL=>GWFSFRDAT(IGRID)%NSTOTRL
NUMAVE=>GWFSFRDAT(IGRID)%NUMAVE
ITMP=>GWFSFRDAT(IGRID)%ITMP
IRDFLG=>GWFSFRDAT(IGRID)%IRDFLG
IPTFLG=>GWFSFRDAT(IGRID)%IPTFLG
NP=>GWFSFRDAT(IGRID)%NP
CONST=>GWFSFRDAT(IGRID)%CONST
DLEAK=>GWFSFRDAT(IGRID)%DLEAK
NUMTIM=>GWFSFRDAT(IGRID)%NUMTIM
WEIGHT=>GWFSFRDAT(IGRID)%WEIGHT
SFRRATIN=>GWFSFRDAT(IGRID)%SFRRATIN
SFRRATOUT=>GWFSFRDAT(IGRID)%SFRRATOUT
FLWTOL=>GWFSFRDAT(IGRID)%FLWTOL
IRTFLG=>GWFSFRDAT(IGRID)%IRTFLG
IOTSG=>GWFSFRDAT(IGRID)%IOTSG
NSEGCK=>GWFSFRDAT(IGRID)%NSEGCK
ITRLSTH=>GWFSFRDAT(IGRID)%ITRLSTH
ISEG=>GWFSFRDAT(IGRID)%ISEG
IDIVAR=>GWFSFRDAT(IGRID)%IDIVAR
ISTRM=>GWFSFRDAT(IGRID)%ISTRM
LTRLIT=>GWFSFRDAT(IGRID)%LTRLIT
LTRLST=>GWFSFRDAT(IGRID)%LTRLST
ITRLIT=>GWFSFRDAT(IGRID)%ITRLIT
ITRLST=>GWFSFRDAT(IGRID)%ITRLST
NWAVST=>GWFSFRDAT(IGRID)%NWAVST
STRIN=>GWFSFRDAT(IGRID)%STRIN
STROUT=>GWFSFRDAT(IGRID)%STROUT
FXLKOT=>GWFSFRDAT(IGRID)%FXLKOT
UHC=>GWFSFRDAT(IGRID)%UHC
SGOTFLW=>GWFSFRDAT(IGRID)%SGOTFLW
DVRSFLW=>GWFSFRDAT(IGRID)%DVRSFLW
SFRUZBD=>GWFSFRDAT(IGRID)%SFRUZBD
SEG=>GWFSFRDAT(IGRID)%SEG
STRM=>GWFSFRDAT(IGRID)%STRM
HSTRM=>GWFSFRDAT(IGRID)%HSTRM
QSTRM=>GWFSFRDAT(IGRID)%QSTRM
HWDTH=>GWFSFRDAT(IGRID)%HWDTH
HWTPRM=>GWFSFRDAT(IGRID)%HWTPRM
SFRQ=>GWFSFRDAT(IGRID)%SFRQ
QSTAGE=>GWFSFRDAT(IGRID)%QSTAGE
SLKOTFLW=>GWFSFRDAT(IGRID)%SLKOTFLW
DLKOTFLW=>GWFSFRDAT(IGRID)%DLKOTFLW
DLKSTAGE=>GWFSFRDAT(IGRID)%DLKSTAGE
XSEC=>GWFSFRDAT(IGRID)%XSEC
AVDPT=>GWFSFRDAT(IGRID)%AVDPT
AVWAT=>GWFSFRDAT(IGRID)%AVWAT
WAT1=>GWFSFRDAT(IGRID)%WAT1
CONCQ=>GWFSFRDAT(IGRID)%CONCQ
CONCRUN=>GWFSFRDAT(IGRID)%CONCRUN
CONCPPT=>GWFSFRDAT(IGRID)%CONCPPT
THTS=>GWFSFRDAT(IGRID)%THTS
THTR=>GWFSFRDAT(IGRID)%THTR
EPS=>GWFSFRDAT(IGRID)%EPS
FOLDFLBT=>GWFSFRDAT(IGRID)%FOLDFLBT
THTI=>GWFSFRDAT(IGRID)%THTI
UZFLWT=>GWFSFRDAT(IGRID)%UZFLWT
UZSTOR=>GWFSFRDAT(IGRID)%UZSTOR
UZWDTH=>GWFSFRDAT(IGRID)%UZWDTH
UZSEEP=>GWFSFRDAT(IGRID)%UZSEEP
DELSTOR=>GWFSFRDAT(IGRID)%DELSTOR
WETPER=>GWFSFRDAT(IGRID)%WETPER
UZDPIT=>GWFSFRDAT(IGRID)%UZDPIT
UZDPST=>GWFSFRDAT(IGRID)%UZDPST
UZTHIT=>GWFSFRDAT(IGRID)%UZTHIT
UZTHST=>GWFSFRDAT(IGRID)%UZTHST
UZSPIT=>GWFSFRDAT(IGRID)%UZSPIT
UZSPST=>GWFSFRDAT(IGRID)%UZSPST
UZFLIT=>GWFSFRDAT(IGRID)%UZFLIT
UZFLST=>GWFSFRDAT(IGRID)%UZFLST
UZOLSFLX=>GWFSFRDAT(IGRID)%UZOLSFLX
SUMRCH=>GWFSFRDAT(IGRID)%SUMRCH
SUMLEAK=>GWFSFRDAT(IGRID)%SUMLEAK
HLDSFR=>GWFSFRDAT(IGRID)%HLDSFR
STRMDELSTOR_CUM=>GWFSFRDAT(IGRID)%STRMDELSTOR_CUM
STRMDELSTOR_RATE=>GWFSFRDAT(IGRID)%STRMDELSTOR_RATE
TOTSPFLOW=>GWFSFRDAT(IGRID)%TOTSPFLOW
C
END SUBROUTINE SGWF2SFR7PNT
C
C-------SUBROUTINE SGWF2SFR7PSV
SUBROUTINE SGWF2SFR7PSV(IGRID)
C Save SFR data for a grid.
USE GWFSFRMODULE
C ------------------------------------------------------------------
C ARGUMENTS
C ------------------------------------------------------------------
INTEGER IGRID
C ------------------------------------------------------------------
GWFSFRDAT(IGRID)%NSS=>NSS
GWFSFRDAT(IGRID)%NSTRM=>NSTRM
GWFSFRDAT(IGRID)%NSFRPAR=>NSFRPAR
GWFSFRDAT(IGRID)%ISTCB1=>ISTCB1
GWFSFRDAT(IGRID)%ISTCB2=>ISTCB2
GWFSFRDAT(IGRID)%IUZT=>IUZT
GWFSFRDAT(IGRID)%MAXPTS=>MAXPTS
GWFSFRDAT(IGRID)%ISFROPT=>ISFROPT
GWFSFRDAT(IGRID)%NSTRAIL=>NSTRAIL
GWFSFRDAT(IGRID)%ISUZN=>ISUZN
GWFSFRDAT(IGRID)%NSFRSETS=>NSFRSETS
GWFSFRDAT(IGRID)%NUZST=>NUZST
GWFSFRDAT(IGRID)%NSTOTRL=>NSTOTRL
GWFSFRDAT(IGRID)%NUMAVE=>NUMAVE
GWFSFRDAT(IGRID)%ITMP=>ITMP
GWFSFRDAT(IGRID)%IRDFLG=>IRDFLG
GWFSFRDAT(IGRID)%IPTFLG=>IPTFLG
GWFSFRDAT(IGRID)%NP=>NP
GWFSFRDAT(IGRID)%CONST=>CONST
GWFSFRDAT(IGRID)%DLEAK=>DLEAK
GWFSFRDAT(IGRID)%NUMTIM=>NUMTIM
GWFSFRDAT(IGRID)%WEIGHT=>WEIGHT
GWFSFRDAT(IGRID)%SFRRATIN=>SFRRATIN
GWFSFRDAT(IGRID)%SFRRATOUT=>SFRRATOUT
GWFSFRDAT(IGRID)%FLWTOL=>FLWTOL
GWFSFRDAT(IGRID)%IRTFLG=>IRTFLG
GWFSFRDAT(IGRID)%IOTSG=>IOTSG
GWFSFRDAT(IGRID)%NSEGCK=>NSEGCK
GWFSFRDAT(IGRID)%ITRLSTH=>ITRLSTH
GWFSFRDAT(IGRID)%ISEG=>ISEG
GWFSFRDAT(IGRID)%IDIVAR=>IDIVAR
GWFSFRDAT(IGRID)%ISTRM=>ISTRM
GWFSFRDAT(IGRID)%LTRLIT=>LTRLIT
GWFSFRDAT(IGRID)%LTRLST=>LTRLST
GWFSFRDAT(IGRID)%ITRLIT=>ITRLIT
GWFSFRDAT(IGRID)%ITRLST=>ITRLST
GWFSFRDAT(IGRID)%NWAVST=>NWAVST
GWFSFRDAT(IGRID)%STRIN=>STRIN
GWFSFRDAT(IGRID)%STROUT=>STROUT
GWFSFRDAT(IGRID)%FXLKOT=>FXLKOT
GWFSFRDAT(IGRID)%UHC=>UHC
GWFSFRDAT(IGRID)%SGOTFLW=>SGOTFLW
GWFSFRDAT(IGRID)%DVRSFLW=>DVRSFLW
GWFSFRDAT(IGRID)%SFRUZBD=>SFRUZBD
GWFSFRDAT(IGRID)%SEG=>SEG
GWFSFRDAT(IGRID)%STRM=>STRM
GWFSFRDAT(IGRID)%HSTRM=>HSTRM
GWFSFRDAT(IGRID)%QSTRM=>QSTRM
GWFSFRDAT(IGRID)%SLKOTFLW=>SLKOTFLW
GWFSFRDAT(IGRID)%DLKOTFLW=>DLKOTFLW
GWFSFRDAT(IGRID)%DLKSTAGE=>DLKSTAGE
GWFSFRDAT(IGRID)%HWDTH=>HWDTH
GWFSFRDAT(IGRID)%HWTPRM=>HWTPRM
GWFSFRDAT(IGRID)%SFRQ=>SFRQ
GWFSFRDAT(IGRID)%QSTAGE=>QSTAGE
GWFSFRDAT(IGRID)%XSEC=>XSEC
GWFSFRDAT(IGRID)%AVDPT=>AVDPT
GWFSFRDAT(IGRID)%AVWAT=>AVWAT
GWFSFRDAT(IGRID)%WAT1=>WAT1
GWFSFRDAT(IGRID)%CONCQ=>CONCQ
GWFSFRDAT(IGRID)%CONCRUN=>CONCRUN
GWFSFRDAT(IGRID)%CONCPPT=>CONCPPT
GWFSFRDAT(IGRID)%THTS=>THTS
GWFSFRDAT(IGRID)%THTR=>THTR
GWFSFRDAT(IGRID)%EPS=>EPS
GWFSFRDAT(IGRID)%FOLDFLBT=>FOLDFLBT
GWFSFRDAT(IGRID)%THTI=>THTI
GWFSFRDAT(IGRID)%UZFLWT=>UZFLWT
GWFSFRDAT(IGRID)%UZSTOR=>UZSTOR
GWFSFRDAT(IGRID)%UZWDTH=>UZWDTH
GWFSFRDAT(IGRID)%UZSEEP=>UZSEEP
GWFSFRDAT(IGRID)%DELSTOR=>DELSTOR
GWFSFRDAT(IGRID)%WETPER=>WETPER
GWFSFRDAT(IGRID)%UZDPIT=>UZDPIT
GWFSFRDAT(IGRID)%UZDPST=>UZDPST
GWFSFRDAT(IGRID)%UZTHIT=>UZTHIT
GWFSFRDAT(IGRID)%UZTHST=>UZTHST
GWFSFRDAT(IGRID)%UZSPIT=>UZSPIT
GWFSFRDAT(IGRID)%UZSPST=>UZSPST
GWFSFRDAT(IGRID)%UZFLIT=>UZFLIT
GWFSFRDAT(IGRID)%UZFLST=>UZFLST
GWFSFRDAT(IGRID)%UZOLSFLX=>UZOLSFLX
GWFSFRDAT(IGRID)%SUMRCH=>SUMRCH
GWFSFRDAT(IGRID)%SUMLEAK=>SUMLEAK
GWFSFRDAT(IGRID)%HLDSFR=>HLDSFR
GWFSFRDAT(IGRID)%STRMDELSTOR_CUM=>STRMDELSTOR_CUM
GWFSFRDAT(IGRID)%STRMDELSTOR_RATE=>STRMDELSTOR_RATE
GWFSFRDAT(IGRID)%TOTSPFLOW=>TOTSPFLOW
C
END SUBROUTINE SGWF2SFR7PSV