!WB THIS IS THE LATEST VERSION OF THE LARGE WATERSHED MODEL !WB AS OF 19 AUG 1999 FWB. IT IS INTENDED TO BE IDENTICAL TO THE !WB STANDARD MODEL EXCEPT THAT IT HAS THE CAPABILITY TO SIMULATE !WB 35000 CELLS, 30 SOIL TYPES, AND 40 RAINGAGES WITH 100 VALUES !WB PER GAGE. IT IS A BETA RELEASE! !WB THIS VERSION INCLUDES CRITICAL SHEAR DETACHMENT COMPONENTS FOR !WB FLOW DETACHMENT, AN UPDATED RAINFALL DETACHMENT COMPONENT, AND !WB A CHANNEL EROSION COMPONENT. 30 SOIL TYPES ARE AVAILABLE TO !WB ACCOMODATE THE INCLUSION OF CHANNEL SOILS. * !WB 19 AUG 1999 UPDATES THE HYDROGRAPH TO INCLUDE ALL NUTRIENT !WB SPECIES IN SEDIMENT-BOUND AND DISSOLVED FORM, OUTPUT IN PPM. * !WB 14 AUG 1999 REINSTATES THE HYDROGRAPH PRINT OPTION. * !WB 8 AUG 1999 FIXES THE FOLLOWING LINE (LINE # 1817 AT THE TIME) !WB IF(FIL.LT.0) FIL=0.0, THE LINE ORIGINALLY STATED THAT IF !WB (FIL.LT.O), OR LT THE LETTER O !WB ALSO, IN SUBROUTINE RAINFA, THE NCHAN VAR WASN'T DEFINED !WB BEFORE IT WAS USED, AND SO THE ARGUMENT NCHAN WAS ADDED TO !WB THE SUBROUTINE CALL * * !WB 27 JULY 1999 FIXES THE RILLWID GT RILLSPACING ERROR MESSAGE !WB PREVIOUSLY IT DIDN'T CONTAIN THE CELL #, RILLWID, RILLSPACING * * !WB 7/14/99 RELEASE FIXES A LT/GE ERROR IN THE SDR CALCULATION !WB FOR PARTICLES LT 0.002 AND RR GT 150 *THIS VERSION INCLUDES SEDIMENT BOUND ORGANIC NITROGEN * AND SEDIMENT BOUND AND SOLUBLE AMMONIUM ** NRZ (7/22/94) * THIS VERSION ELIMINATES P,PH,RALPHA,RBETA, AND RGAMA FROM THE INPUT * FILE. P(20), RALPHA(20), AND RGAMA(20) ARE ALSO REMOVED FROM THEIR * RESPECTIVE COMMON STATEMENTS. RBETA IS STILL USED. * * 9/11/94 * THIS VERSION HAS THE ABILITY TO ACCEPT MULTIPLE CHANNEL NETWORKS * IN THE INPUT FILE AND PRODUCES AN OUTPUT FILE FOR EACH CHANNEL. * * (11/3/94) * THIS VERSION CONTAINS AN OPTION TO ENTER SATURATED HYDRAULIC * CONDUCTIVITY AS AN INDEPENDENT INPUT. THE INPUT FILE HAS BEEN * REVISED TO ACCOMODATE THIS FEATURE. * * THIS VERSION UTILIZES A SEPARATE INPUT FILE FOR FERTILIZER * APPLICATIONS. AN ADDITIONAL INPUT FILE HAS BEEN ADDED AND THE MAIN * INPUT FILE HAS BEEN MODIFIED. * * A MODIFIED SCREEN OUTPUT INDICATES CALENDAR MONTH AND DAY, RAIN * EVENTS, AND FERTILIZER APPLICATIONS * * 10/12/94 * THIS VERSION CONTAINS A CORRECTION TO THE NITRIFICATION ALGORITHM * TO ACCOUNT FOR FERTILIZER APPLICATIONS LESS THAN 20 DAYS BEFORE A * ROTATION. * * THIS VERSION CONTAINS AN OPTION TO PLACE AN IMPOUNDMENT AT THE END * OF ANY CHANNEL NETWORK. THE NECESSARY STRUCTURAL DATA MUST BE * INCLUDED IN THE INPUT FILE. * * THIS VERSION ALLOWS THE USER TO ENTER A MEASURED VALUE OF SATURATED * HYDRAULIC CONDUCTIVITY. * * 7/29/95 * THIS VERSION ADDS THE CAPABILITY TO INCLUDE 28 ROTATION END DATES AS * OPPOSED TO THE PREVIOUS 20 * C*********************************************************************** C*********************************************************************** C*********************************************************************** C***** ****** C***** ****** C***** A N S W E R S ****** C***** ****** C***** (AREAL NONPOINT SOURCE WATERSHED ****** C***** ENVIRONMENT RESPONSE SIMULATION) ****** C***** ****** C***** ****** C***** DISTRIBUTED PARAMETER MATHEMATICAL MODEL OF A RAINFALL ****** C***** EVENT ON A CATCHMENT, WITH EROSION AND DEPOSITION AS A ****** C***** FUNCTION OF PARTICLE SIZE. ****** C***** ****** C***** ****** C***** AUTHORS: D. B. BEASLEY, L. F. HUGGINS, AND J. R. BURNEY ****** C***** ****** C***** AGRICULTURAL ENGINEERING DEPARTMENT, PURDUE UNIVERSITY ****** C***** WEST LAFAYETTE, INDIANA 47907 ****** C***** ****** C***** ****** C***** AUTHORS: THEO DILLAHA ****** C***** DEVELOPMENT OF EXTENDED SEDIMENT MODEL ****** C***** LAST MODIFY DATE: SEPTEMBER 1, 1981 ****** C***** ****** C***** INCORPORATION OF EXTENDED SEDIMENT MODEL BY ****** C***** DILLAHA INTO CURRENT ANSWERS MODEL FOR FORTRAN ****** C***** 77 COMPILER FOR VIRGINIA TECH SYSTEM. ****** C***** FEBRUARY 17, 1986. ****** C***** ****** C***** AGRICULTURAL ENGINEERING DEPARTMENT, VIRGINIA TECH ****** C***** BLACKSBURG, VIRGINIA 24061 540-961-6813 ****** C***** ****** C***** ****** C***** ****** C***** ****** C*********************************************************************** C*********************************************************************** C*********************************************************************** C***** ****** C***** ****** C***** ****** C***** THIS VERSION OF ANSWERS CONTAINS: ****** C***** ****** C***** 1) 35000 CELL CAPABILITY ****** C***** 2) 3-PER-PASS ALGORITHM ****** C***** 3) IMPROVED DATA VERIFICATION DIAGNOSTICS ****** C***** 4) STRUCTURAL PRACTICES ****** C***** 5) MODIFIED INPUT FORMATS (SEE USER'S MANUAL) ****** C***** 6) MODIFIED DETACHMENT AND TRANSPORT RELATIONSHIPS ****** C***** 7) MODIFIED OUTPUT FORMATS ****** C***** ****** C*********************************************************************** C*********************************************************************** C C !WB*********************************************** !WB*********************************************** !WB***** !WB***** When the comment indicator is !WB !WB***** it indicates that the comment was !WB***** inserted by Wes Byne in FALL 1998, !WB***** or SPRING 1999. !WB***** !WB*********************************************** !WB*********************************************** !TMN ********************************************* !TMN COMMENTS INITALIZED TMN INDICATES !TMN ADDED BY TONE MERETE NORBDERG !TMN SPRING 2000 !TMN ********************************************* C ****** DISTRIBUTED PARAMETER MATHEMATICAL MODEL OF A RAINFALL C ****** EVENT ON A CATCHMENT, WITH EROSION AND DEPOSITION. C IMPLICIT DOUBLE PRECISION A-H,O-Z C C **** MAXIMUM NUMBER OF SOIL TYPES IS 30. C COMMON /CSOIL/ A(30),FC(30),GWC(30) COMMON /GRAMPT/ CL(30),SA(30),ST(30),OM(30),AC(30) & ,AO(30),BC(30),BO(30),PHI(30),VCF(30),WCF(30),CFC(30), & CEC(30),EAC(30),PHIC(30),XF(30),PSIF(30),CBF(30), & THETAR(30),KS(30),CF(30),Z(30),LF(30),CS(30),SCF(30), & CRC(30),KE(30,30),ZC(30),BD(30) DOUBLE PRECISION KS,LF,KE ! COMMON /ETPES/LAI(20,11),ESU(30),LAI1(20),POTLAI(20),EDX(20) ! &,SUMLAI(20) COMMON /ETPES/LAI(20,11),ESU(30),LAI1(20),POTLAI(20) &,SUMLAI(20) COMMON /EDX/ EDX(30) DIMENSION S1EP(35000),S2EP(35000),TTIME(35000),PEP(35000), 1ES(35000) DOUBLE PRECISION LAI,LAI1 COMMON /ASMF/ ASMBF(30),FCAP1(30),TP1(30),RESWAT(30),DF1(30) INTEGER DAYBEG,SIMDUR,TEMPC,SOITEM,RADI,RAITES,YERBEG,RNUT COMMON /ROT/ IROT1,IROT(20,644) INTEGER IROT1,IROT C *** NRZ 9/15/94 C *** CHANGED DIMENSION OF SOME VARIABLES TO CORRESPOND WITH C *** NMAX+ISTRUC+1+NCHAN COMMON /PHOS1/ P0SOIL(35000),SSA(30,8),SSAT(30),EDI(35000), & P0(35000,8),ERP(8),STOLD(35000,8),SEDNEW(35000,8),PPT(35000,8), & PI(35050,8),PSEL(35000),STNEW(8),P2(8),PCELL(35000,8),PE(8) & ,DRFT(8) COMMON/NITRO1/ A0SOIL(35000),ANPT(35000,8),ANI(35050,8), & ANSEL(35000),AN2(8),ANCELL(35000,8),ANE(8),AN0(35000,8) & ,CNH4(35000) COMMON/NITRO2/ O0SOIL(35000),ONPT(35000,8),ONI(35050,8), & ONSEL(35000),ON2(8),ONCELL(35000,8),ONE(8),ON0(35000,8) C *** NRZ 9/15/94 COMMON /PLANTN/DATPLA(20),DATHAR(20),CP1(20),CP2(20),DMY(20) & ,YP(20),ROTMAX(20),ROTDAY(20),RLAIMX(20) & ,RES(20),RES20(20),RES90(20) INTEGER DATPLA,DATHAR,ROTMAX,ROTDAY C **** NRZ 9/14/94 C **** CHANGE DIMENSIONS TO ACCOMODATE MULTIPLE OUTLETS C **** AND DIMENSION OTHERS DIMENSION PSSI(101,10),SPSSI(101,10),ANSSI(101,10),ONSSI(101,10) & ,ANH4SI(101,10),ANO3SI(101,10) DIMENSION SIG(10),VOL(10),PSIG(10),ANSIG(10),ONSIG(10),XS(10), & VOL1F(10),VOL1X(10),RNO3(10),RNH4S(10),RNH4SE(10),RPHOS(10), & RORGN(10),RSEDP(10),SPT(10),PSPT(10) C **** NRZ 9/14/94 COMMON /CUMIN/ CUMIN1(35000),rbit0(35000),testi(35000) & ,timpon(35000),tpon(35000) C **** NRZ 9/15/94 C **** CHANGED DIMENSIONS OF SOME VARIABLES TO CORRESPOND WITH C **** NMAX+ISTRUC+1+NCHAN COMMON /SOLUB/ SP2(35000),PEXT(35000),PK(30) & ,RBETA(30),SPI(35050),CGEN1(35000) & ,T13(35000),SPSP(35000) COMMON/WATNH4/VOLSZ(35000),SZNH4(35000),AINH4(35050),STONH4(35000) & ,OUTNH4(35000),EDINH4(35000),VOLSZ1(35000),VOLSOI(35000) COMMON/NO3/SZNO3(35000),AINO3(35050),STONO3(35000),OUTNO3(35000) & ,CNO3(35000),EDINO3(35000),CLENO3(35000) C **** NRZ 9/15/94 COMMON/OUT/SUMSED(35000),SUMNO3(35000),SUMNHW(35000),SUMNHS(35000) & ,SUMTKN(35000),SUMPO4(35000),NO3SEL(35000),NHWSEL(35000), &NHSSEL(35000),TKNSEL(35000),PO4SEL(35000) DOUBLE PRECISION NO3SEL,NHWSEL,NHSSEL C C **** MAXIMUM NUMBER OF SURFACE AND CROP TYPES IS 20. C COMMON /CROUGH/ ROUGH(20),HU(20),DIR(21),PIT(40,20),PER(20) C C **** MAXIMUM NUMBER OF RAINGAGES IS 40 WITH 200 VALUES PER GAGE. C COMMON /CRGAGE/ RC(40,200),TC(40,200),R(40,21),FRA(40),JTR(40), 1RATE(40),SR(40),NF(40),RATE2(40) C C .... PARAMETERS USED IN THE EXTENDED SED SUBROUTINE C COMMON /ZSEDI/ NPART,NWASH,NWASH1 COMMON /ZSEDR/ VISCOS,AGRAV,SWH2O,YALCON,SE(8),VS(35000),DIA(8), 1SG(8),FV(8),CY1(8),CY2(8),CY4(8),DIAMM(8),EQSDIA(8),EDMM(8), 2F(30,8),CE1,CE2,CE3,CE4,CE5,CE6 !WB Changed F(10,8) to F(30,8) to accomodate 30 soil types C C **** MAXIMUM NUMBER OF OVERLAND ELEMENTS PLUS CHANNEL ELEMENTS C **** IS 35000 = NMAX. C ****** NRZ 9/15/94 C ****** DUE TO ADDITION OF MULTIPLE OUTLETS, SI AND QI (AS WELL AS C ****** OTHER ARRAYS ORIGINALLY USING THE VARIABLE NN AS AN ELEMENT C ****** OF THE ARRAY) MUST BE DIMENSIONED TO NMAX+ISTRUC+1+NCHAN COMMON /CFLOW/ Q(35000),RFL(35000),FLINS(35000),SS(35000), 1PIV(35000),B(35000),DR(35000), 2SL(35000),SEL(35000),SI(35050,8),QI(35050),DIN(35000), 3SST(35000,8),PIVTMP(35000),SSTMP(35000) COMMON /CFLOW2/NR(35000),NC(35000),S(35000) C *** NRZ C *** ADD COMMON BLOCK FOR PERCENTAGE OF CELL AREA "LEAKING" OUTSIDE THE C *** WATERSHED COMMON /LEAKY/ OUTSID C *** NRZ 9/15/94 C C ****** ARRAYS SI AND QI MUST BE DIMENSIONED TO A SIZE = NMAX+ISTRUC+2 C ****** TO HOLD, IN ORDER, SEDIMENT AND FLOW FROM THE WATERSHED OUTLET C ****** ELEMENT, STRUCTURAL PRACTICES AND ANY "LEAKY" ELEMENTS. C DIMENSION FILTS(35000), CWID(35000),CWIDTMP(35000) COMMON /CSURF/ SUR(35000),RANE(35000),SOIL(35000) INTEGER SUR,TIAL(35000),RANE,SOIL DIMENSION ASMVOL(35000),ASMLIM(30),SOIVOL(30) & ,FCVOL(30),WP(30),RATEMX(30) c fert array changed from 20 to 99: JLCollado, oct-97 !WB CHANGED REMAINING VARIABLES TO ACCOUNT FOR 30 SOIL TYPES DIMENSION RNUTNI(99),RNUTAM(99),RNUTP(99) C *** NRZ 9/12/94 C *** ADD VARIABLES FOR FERTILIZER FILE c dimension changed from 20 to 99 COMMON /FERT/ IFERT DIMENSION TMPNI(99),TMPAM(99),TMPP(99) C *** ADD COMMON BLOCK FOR NITRIFICATION CORRECTION COMMON /YEAR/ LDYEAR C *** ADD COMMON BLOCK FOR EXTRA OUTPUT OPTIONS COMMON /XPRINT/ NSBS,NPDAY(10) CHARACTER*7 XPFIL(10) C *** NRZ 9/12/94 COMMON /ASMP/ASMPER(35000) COMMON /TRANSF/POTMIN(35000),SOILN(35000),XMIN(35000),AMON(35000) & ,NIT(35000),DNI(35000),UPNH4(35000),UPNO3(35000),TDMN2(35000), & ROTR(35000),RFON(35000) DOUBLE PRECISION XMIN,NIT COMMON /TRAP/PMINP(35000),SOILP(35000),MINP(35000),PLAB(35000), & UPPHOS(35000),TDMP2(35000),SORGP(35000),PSOL(35000), & EDILAB(35000) DOUBLE PRECISION MINP COMMON /PARTITION/PKDA(30),PKDP(30),PSP(30) !WB CHANGED ARRAY SIZES TO 30 C C **** NUMBER OF PRINT AND PLOT POINTS IS 101 MAXIMUM. C C **** NRZ 9/14/94 C **** CHANGE DIMENSION OF CERTAIN VARIABLES TO ACCOUNT FOR MULTIPLE C **** CHANNEL OUTLETS DIMENSION T(101),Q1(101,10),RW(101,10),SSI(101,10), & SSCON(101,10),ER(8) C **** ADDED VARIABLES FOR CHANNEL NETWORKS COMMON /OUTLET/ NCHAN,NIOUT(9),NJOUT(9),MOUT(9),CHNUM(35000), & CHOUT(9),NCELLS(9),CHNUMBER(35000) INTEGER CHNUM,CHOUT,CHNUMBER C **** NRZ 9/14/94 DIMENSION PP(14), QA(30000), TT(20) CHARACTER*4 PP, TT DATA PP(1),PP(2),PP(3),PP(4),PP(5),PP(6),PP(7),PP(8),PP(9),PP(10), 1PP(11),PP(12),PP(13),PP(14)/' IN.','/HR.',' AC.',' FT.',' LB.', 2' PPM','/AC ',' MM','/H ',' HA ',' M ',' KG','MG/L','/HA '/ C **** NRZ (8/29/94) C **** NEW VARIABLES AND COMMON BLOCKS FOR IMPOUNDMENT MODEL COMMON /IMPDIM/ BASE,WIDTH,SLOPE,ORIF,CI,FI,MAXHGT,NIMP DOUBLE PRECISION BASE(10),WIDTH(10),SLOPE(10),ORIF(10),CI(10), &FI(10),MAXHGT(10) COMMON /FWATER/ AFWEV,DFWEV DIMENSION SEDG(10,8),SEDH(10,101,8) DOUBLE PRECISION ONSEDG(10,8),ONSEDH(10,101,8),ONSEDI(10,8), &ONSEDO(10,8),ONSEDT(10) DIMENSION PSEDG(10,8),PSEDH(10,101,8),PSEDI(10,8), &PSEDO(10,8),PSEDT(10) DIMENSION ANSEDG(10,8),ANSEDH(10,101,8),ANSEDI(10,8), &ANSEDO(10,8),ANSEDT(10) DIMENSION SEDOR(10,8),SEDOT(10,8),SEDWT(10,8),DIAM(8),TSEDI(10,8) &,TSEDO(10,8),TTSEDO(10) DIMENSION DANSED(10),DNO3O(10),DNH4O(10),DONSED(10),DPHOSO(10) &,DPSED(10),DTSEDO(10),RUNO(10),TNO3O(10),TNH4O(10),TPHOSO(10) &,TRUNO(10),TRUNOM(10),RUNVOL(10),RUNOM(10) DIMENSION SEDZO(10,8),SEDZOT(10,8) C **** NRZ (8/29/94) !WB BEGINNING OF NEW VARIABLES FOR NEW DETACHMENT ROUTINES !WB soil variables: COMMON/SOILVAR/CLAY(30),SAND(30),SILT(30),VFSPER(30),VFS(30), 1ORGMAT(30),MASSCF(30),RANROU(30),RANROUM(30) DOUBLE PRECISION MASSCF !WB rill erodibility variables: COMMON/RILLVARS/KRBASE(35000),KRBR(35000),BR(20),BURRES(20), 1KRADJHLD(35000),KRCONS(35000),KRSC(35000),KRADJ(35000) DOUBLE PRECISION KRBASE,KRBR,KRADJHLD,KRCONS,KRSC,KRADJ !WB critical shear variables: COMMON/CRTSHEAR/TAUCB(35000),TAURR(35000),TAUCHLD(35000),TAUCONS 1(35000),TAUSC(35000),TAUCADJ(35000),TAUEFF !WB interrill erodibility variables: COMMON/IRILLVARS/KIBASE(35000),KICAN(35000),KIGRCOV(35000),KICONS 1(35000),KISC(35000),KIADJ(35000),CANOPY(20),AUCFACT(20),HEIGHT(20), 2MAXPLHGT(20),HGTFACT(20),GROWFACT(20) DOUBLE PRECISION KIBASE,KICAN,KIGRCOV,KICONS,KISC,KIADJ,MAXPLHGT !WB interrill cover common block: COMMON /IRILLCOV/ INRCOV(20),INRCOVI(20),INRCOVF(20),INRFACT(20), 1LROOT(21),DROOT(21),KDROOTI(35000),KLROOTI(35000),DDROOTI(21), 2DDROOTF(21),DDRTFAC(21),LRFAC(21),LIVEROOT(21),KDROOTR(35000), 3KLROOTR(35000) DOUBLE PRECISION INRCOV,INRCOVI,INRCOVF,INRFACT,LROOT,KDROOTI, 1KLROOTI,LRFAC,LIVEROOT,KDROOTR,KLROOTR !WB rill erosion variables: COMMON/RILLEROS/NORILLS,RILLSPC(20),QEFF,RILLWID,MNSOIL(21), 1MNTOT(21),FLOWDEP,HYDRAD,DCAP,FCFRAC(30),FOFD,FPOFD,FDPOFD, 2FLDEPOLD,MNCHNSL(35000),MNCHNTOT(35000),MNCS(30),MNCT(30),MNCSTMP 3(35000),MNCTTMP(35000),MAXWID,NOTILL(21),NOEROS(21),DWSOIL, 4HYDRADOLD(35000) DOUBLE PRECISION MNSOIL,MNTOT,MNCHNSL,MNCHNTOT,MNCS,MNCT,MNCSTMP, 1MNCTTMP,NORILLS,MAXWID !WB interrill erosion variables COMMON /IRILLEROS/RNOFIR,SEDDR(35000,8),DIINT(35000,8),DETR(8) 1,DETF(8),DACT(35000,8) !WB PLANT GROWTH VARIABLES COMMON /PLANTS/ DAYNOW(35000),YEARNOW(35000),DYYRNOW 1(35000),DAYTHEN(35000),YEARTHEN(35000),DYYRTHEN(35000), 2DAYDIFF(35000),BEGROTDT(35000) !WB CHANNEL BOTTOM EROSION VARIABLES COMMON /CHANEROS/WIDINC(35000),DOWNRATE(35000), 1DEPTHINC(35000),IMPERM(30),ROCKBOT(35000),RBTEMP(35000), 2BULKDENS(30),CHNSOIL(35000),CHNSL(35000),CHNSLTMP(35000) 3,DEPRATE(35000),DEPPREV(35000),CONSTHLD(35000),XHOLD(35000) 4,CONSTTMP(35000),XTMP(35000) COMMON /ARMOUR/ARMOUR(35000),NOERODE(35000) 1,NERODTMP(35000) !WB HYDROGRAPH PLOT VARIABLES COMMON /HYPLT/PRINHYD,IMPFLAG,QHYP(101,10),PHYP(101,10) 1,DPHYP(101,10),A4SHYP(101,10),A4DHYP(101,10),ONHYP(101,10) 2,A3HYP(101,10) CHARACTER(11) HYPNAM(10) DOUBLE PRECISION DIFF,RGTSID,LFTSID,IMPERM,NOERODE,NERODTMP INTEGER CNT,CNTER,CNTFLAG,NOTILL,INIT,NOEROS,CHNSL,CHNSOIL, 1CHNSLTMP,PRINHYD DOUBLE PRECISION PCPANNUAL,RUNANNUAL,SEDANNUAL,NO3ANNUAL DOUBLE PRECISION NHWANNUAL,NHSANNUAL,PO4WANNUAL DOUBLE PRECISION PO4SANNUAL,TKNANNUAL,LNO3ANNUAL,LNO3DAY DOUBLE PRECISION CUMMULATIVE,MYQ,MYQA,STORAGE COMMON ANNUALOUT !WB Sediment Erosion routine information: Some equations and !WB calculations in the sediment subroutine are not placed in the !WB location that will allow optimal calculation efficiency. This is !WB recognized, and was done in order to ease understanding of the !WB methodology at the cost of computational efficiency. !WB END OF NEW VARIABLES FOR NEW DETACHMENT ROUTINES !RZ COMMON STATEMENT FOR ATMOSPHERIC DEPOSITION ROUTINE COMMON /DEPOSITION/ O0ADD(35000),A0ADD(35000),P0ADD(35000) !RZ IRRIGATION VARIABLES COMMON /IRRIG/ IRRFLAG,IRRCROP,DEFLIMIT(20),STARTDAY(20), 1ENDDAY(20),FREQ(20),IRREFF(20),IRRATE(20),DURATION(20), 1IRRTARGET(30),LIMIT(20),IIRRI,IRRCYCLE(20),LASTIRR(20),SKIPFLAG, 1CROPNOIRR(20),IRRFLAG2(20) INTEGER SKIPFLAG,STARTDAY,ENDDAY,FREQ,LIMIT,CROPNOIRR DOUBLE PRECISION IRREFF,IRRATE,DURATION,IRRTARGET COMMON /MOISTURE/ XMOI(35000) !RZ xmoi was changed from local to global variable on 8/9/2001 for ease of !RZ use in the irrigation subroutine !RZ URBAN BMP VARIABLES COMMON /BMP/ HEIGHTSED(300,8,1500), 1SEDINPOND(300,8,1500),PHOSINPOND(300,8,1500), 2ANITINPOND(300,8,1500),ONITINPOND(300,8,1500), 3ORIFICEH(300),ORIFICED(300),ORIFICEN(300), 4OUTSLOPE(300) COMMON /BMP2/ PONDAREA(300),NRO(300),H2ODEPTH(300), 6ORAREA(300),WEIRVOL(300),ORVOL(300),ORTOP(300), 7MAXFLOW(300),SOLP(300),SOLNH4(300),SOLNO3(300), 8LOST(300),WLOST(300),ORBOT(300),TIPE(300), 9PIPEN(300),PIPED(300),PIPEL(300),RISD(300),PIPEAREA(300), 1RISH(300) INTEGER TIPE COMMON /BMP3/ POND(35000),STREAM(300),SUB(300) INTEGER POND,SUB COMMON /BMPPRINT/ TOTALIN(300),TOTALLOST(300), 1TOTALWLOST(300),TOTALINF(300),TOTALEVAP(300),TOTALSED(300), 2TOTALPHOS(300),TOTALANIT(300),TOTALONIT(300),TOTALDEPSED(300), 3TOTALOUTSED(300),TOTALOUTPHOS(300),TOTALOUTANI(300), 4TOTALOUTONI(300),TOTALDEPPHOS(300),TOTALDEPANI(300), 5TOTALDEPONI(300),UOLD COMMON /BMPPRINT2/ TOTALSOLP(300),TOTALSOLNH4(300), 6TOTALSOLNO3(300),TOTALLOSTSOLP(300),TOTALLOSTSOLNH4(300), 7TOTALLOSTSOLNO3(300),TOTALINFP(300),TOTALINFNH4(300), 8TOTALINFNO3(300) DOUBLE PRECISION LENGTH,MAXFLOW,LOST,PONDWIDTH,WEIRH INTEGER OUTLET,BMPLOC,UOLD DIMENSION CALLBMP(35000) INTEGER CALLBMP,BMPFLAG COMMON /URBAN/ SEL2(35000,8),ROADWIDTH(20),URBSOIL(35000), 1PRTCLSSEL(35000,8),DETCAP(8),TRANSCAP(8),URB(35000),URBCR,ISRURB, 2STORM(35000),CURB(35000) INTEGER URBSOIL, URBAN, URB, URBCR, STORM, CURB COMMON /BMP4/ ENDNO3SI,MYSHADOW(35000),MAXPOND INTEGER MAXPOND DIMENSION A1DUMMY(3,300,24), A2DUMMY(35000), A3DUMMY(35000), 1A5DUMMY(3,300,2) INTEGER A1DUMMY, A2DUMMY DIMENSION CROP(20,2) CHARACTER*4 CDUMMY, CROP CHARACTER*2 A5DUMMY DATA CDUMMY/' '/ LOGICAL ARESULT,BRESULT CUMMULATIVE=0.0 C **** OPENING INPUT FILE--ANSWERS.INP OPEN (UNIT=1, FILE='ANSWERS.INP', STATUS='OLD') OPEN (UNIT=8, FILE='WEATHER.INP', STATUS='OLD') C** WDB 5/23/94 C** OPEN A SEPARATE FILE FOR AVERAGE ANNUAL OUTPUT SENT BACK TO GIS OPEN (UNIT=5, FILE='ANSWGRID.OUT', STATUS='UNKNOWN') C** WDB 5/23/94 !TMN 4/14/00 !TMN OPEN A SEPARATE FILE FOR ANNUAL OUTPUT OPEN (UNIT=300, FILE='ANNUAL.OUT', STATUS='UNKNOWN') !TMN C **** OPENING OUPUT FILE--ANSWERS.OUT OPEN (UNIT=2, FILE='ANSWERS.OUT', STATUS='UNKNOWN') !WB OPENING RILL OUTPUT FILE OPEN (UNIT=101,FILE='RILL.OUT',STATUS='UNKNOWN') !WB OPENING SCRATCH INTERRILL OUTPUT FILE OPEN (UNIT=102,FILE='IRILL.OUT',STATUS='UNKNOWN') !RZ OPENING FILE TO OUTPUT QA(I) VARIABLES FOR DEBUGGING OPEN (UNIT=377,FILE='VARIS.OUT',STATUS='UNKNOWN') OPEN (UNIT=379,FILE='VARIS2.OUT',STATUS='UNKNOWN') *************************************************************** !RZ ****************HEADER FOR VARIABLE OUTPUT FILE********** ! WRITE (377,338) 338 FORMAT (1X,"M",4X,"B(M)",4X,"QA(IY)",2X,"MYQA",4X,"SSTOR", & 3X,"Q2",6X,"Q(M)",4X,"SS(M)",3X,"S(M)",4X,"FLINS(M)") !WB **** CE6 IS A CONSTANT ASSOCIATED WITH THE OLD EROSION EQNS, !WB BUT WAS NOT REMOVED B/C IT IS USED IN SEVERAL SUBROUTINES CE6=62.3174 READ (1,280) (TT(I),I=1,19) !WB Reads first line in input file WRITE (2,290) (TT(I),I=1,19) !WB Writes first line in input file to output file ***********RILL & IRILL FILE HEADER***** WRITE (101,*) 'LDAY',' SED ',' JK ','DAYDIFF',' KRBASE', 1' TAUCB',' TAURR',' TAUCHLD' WRITE (101,*) ' KRCONS',' KRSC',' KRBR',' KRADJ', 1' TAUCONS',' TAUSC',' TAUCADJ',' SOIL' WRITE (101,*) ' KDROOTR',' KLROOTR' WRITE (102,*) 'LDAY ',' SED ',' JK',' DAYDIFF',' KIBASE', 1' HEIGHT',' CANOPY',' KICAN' WRITE (102,*)' INRCOV',' KIGRCOV',' KICONS', 1' KISC',' LROOT',' DROOT' WRITE (102,*)' KLROOT',' KDROOT',' KIADJ',' SOIL' !WB END OF OUTPUT HEADERS TO RILL/IRILL OUTPUTS !TMN WRITE HEADER FOR ANNUAL OUTPUT WRITE(300,2202) 2202 FORMAT(///,30X,24H**** ANNUAL OUTPUT ****,//) WRITE(300,3099) WRITE(300,3098) 3099 FORMAT(1X,4HYEAR,1X,9H PRECIP ,1X,9H RUNOFF ,1X,9HSEDIMENT , & 1X,9H DIS-NO3 ,1X,9H DIS-NH4 ,1X,9H SED-NH4 ,1X,9H DIS-PO4 , & 1X,9H SED-PO4 ,1X,9H SED-TKN, 1X,11H LEACH-NO3) 3098 FORMAT(7X,1X,7H MM ,1X,9H MM ,1X,9H KG/HA , &1X,9H KG ,1X,9H KG ,1X,9H KG , &1X,9H KG ,1X,9H KG ,1X,9H KG ,1X,9H KG/HA ) !TMN END OF INPUT HEADER FOR ANNUAL INPUT C C **** READ, TRANSFORM AND RETURN INPUT INFORMATION. C CALL XDATA (NDT,KPR,N,CONV,CU,SF,IT,NN,ICR,NFI,CU2,ISTRUC,SB,TMIN, &TMAX,NRG,DX,GRF,NEXP,DC,PP,FILTS,CWID,AREA,AREA2,DT,NMAX,CU1, &DAYBEG,SIMDUR,ISR,YERBEG,CLAYAV,CALLBMP,CROP) !WB NDT = # lines hydrograph input, KPR = # time increment routings !WB between print lines, N = number of overland flow cells, !WB CONV = catchment conversion, CU = conversion, SF = segment factor !WB = max. projected catchment discharge, IT = unknown, !WB NN = # overland flow + channel elements + 1, ICR = # cropping !WB practices, NFI = max # of time increments b/t infiltration !WB recalc.'s, CU2 = conversion, ISTRUC = counter for structural !WB practices, SB = ave. overland flow conveyance coeff., TMIN = min. !WB time value in any hyetograph, TMAX = maximum time, NRG = # rain !WB gages, DX = element width, GRF = fractional rate of baseflow !WB release, NEXP = unknown, DC = tile drainage coeff., !WB PP = alphanumeric unit descrip., FILTS = infil. cap. for !WB element i, CWID = width of channel seg. i, AREA = catchment area !WB as sum of element areas, AREA2 = element or channel area, !WB DT = time increment, NMAX = max. # of elements, !WB CU1 = conversion, DAYBEG = beginning day of simulation, SIMDUR = !WB simulation duration, ISR = # of soil types, !WB YERBEG = beg. year of the simulation, CLAYAV = unknown CLOSE(1) LASTRAITES=DAYBEG LDAYOLD=0 !RZ URBAN these variables are used in the ATMDEP subroutine and must be initialized CONFAY=DX*DX/10000. !WB (element width)^2 / 10000 DO 5550 J=1,N !WB do this loop from J = counter to # overland flow el's !RZ IF THE CELL IS URBAN, THEN NONE OF THESE NEEDS TO BE CALCULATED IF (URB(J).EQ.1) GO TO 5550 K=SOIL(J)/256 !WB = soil type / 256 ASMVOL(J)=ASMBF(K)*(TP1(K)/CU1) !WB ASMBF = ASM(I) ASMPER(J)=ASMBF(K) VOLSZ1(J)=EDI(J)*PHI(K) !WB = effective depth of interaction * porosity VOLSOI(J)=EDI(J)*BD(K) !WB = EDI * bulk density VOLSZ(J)=EDI(J)*0.001*DX*DX*PHI(K) !WB = EDI * 0.001 * side length * side length * porosit 5550 CONTINUE *MAX RATE OF NITRIFICATION IS 100MG/KG/WEEK !RZ URBAN::CONSIDER MOVING THIS EQUATION INTO THE PREVIOUS LOOP. THE PREVIOUS LOOP !RZ CALCULATES ALL SORTS OF USELESS STUFF (I.E, CALCULATES STUFF SEVERAL TIMES OVER) !RZ FOR THE SOILS; IN FACT, MOST OF THE LOOP CONSISTS OF SOIL ASSOCIATED CALCULATIONS WHICH !RZ COULD BE MOVED INTO A SOIL LOOP LIKE 5551 BELOW. DO SOMETHING ABOUT THIS. DO 5551 K=1,ISR !WB do this loop from counter J=1 to # of soil types !RZ URBAN - IF THE SOIL IS URBAN NONE OF THESE NEED TO BE CALCULATED IF (URBSOIL(K).EQ.1) GO TO 5551 ASMLIM(K)=(FCAP1(K)-FC(K))*(TP1(K)/CU1)*0.25+FC(K)*(TP1(K)/CU1) !WB ASMLIM(K) = (field cap of soil K - wilting point) * (TP1 / conv.) !WB * 0.25 + wilt pt * TP1 / conv. WP(K)=FC(K)*TP1(K)/CU1 !WB = wilt pt * porosity / conversion FCVOL(K)=FCAP1(K)*(TP1(K)/CU1) !WB field cap (mm) = field cap as fraction of pore space * !WB (porosity / conv) SOIVOL(K)=DF1(K)*DX*DX*BD(K) !WB soil mass of layer = depth of horizon * side length*side length !WB * bulk density of soil RATEMX(K)=0.0001*SOIVOL(K)/7. !WB max nit. rate = 0.0001 * soil mass of soil layer / 7. 5551 CONTINUE DO 5532 JK=1,ICR !WB do this loop from counter JK=1 to # of cropping practices IF(DATPLA(JK).GT.DATHAR(JK)) DATHAR(JK)=DATHAR(JK)+365 !WB if plant date > harvest date, then harvest date moves to next year LDATE=(DATHAR(JK)-DATPLA(JK))+1 !WB growth duration = (harvest date - plant date) +1 RLENGT=(DATHAR(JK)-DATPLA(JK)+1)/10. !WB unknown = ((harv. date - plant date) +1) / 10 !RZ this appears to be the length for each stage of the growth; i.e., the !RZ length of time that a particular LAI is in effect for a crop; this matches !RZ with the calculations in loop 5531 below. For reference, see table 6a. in the !RZ input guide !RZ URBAN::urban 'crop' types do not have LAI, skip over following calculations IF (JK.LT.URBCR) GO TO 5532 DO 5531 LL1=1,10 !WB do this loop 10 times? *LDATE REPRESENT GROWTH DURATION POTLAI(JK)=(LAI(JK,LL1+1)+LAI(JK,LL1))*0.5*RLENGT & +POTLAI(JK) !WB sum of potential lai from planting to harvest = !WB (lai (crop practice, next count step) + !WB lai (crop practice, this count step)) * 0.5 * !WB ((harv date - plant date) + 1) / 10 + potential !WB lai from crop practice 5531 CONTINUE 5532 CONTINUE !WB RESET CHANNEL WIDTH INCREASE AT THE BEGINNING OF THE SIMULATION N2=NN-1 DO LL1=N+1,N2 WIDINC(LL1)=0. DEPTHINC(LL1)=0. DEPRATE(LL1)=0. DEPPREV(LL1)=0. INIT=0 !WB INIT IS A FLAG/COUNTER THAT ALLOWS THE SED INITIALIZATION TO !WB ONLY OCCUR ONCE, AS REDOING THE LOOP MULTIPLE TIMES CAUSES ERRORS END DO DO 5555 IDATE=1,SIMDUR !WB do this loop from day of simulation up to simulation duration * print *,' DAY OF SIMULATION IS ',IDATE *get leaf area index and interpolate for a specific date *LDAY REPRESENT THE CURRRENT DAY IN JULIAN CALENDAR C *** NRZ C *** ADDED CORRECTION FOR LEAP YEAR IF(LDAY.GE.365 .AND. MOD(YERBEG,4).NE.0.) THEN YERBEG=YERBEG+1 DAYBEG=DAYBEG-365 ELSEIF (LDAY.GE.366 .AND. MOD(YERBEG,4).EQ.0) THEN YERBEG=YERBEG+1 DAYBEG=DAYBEG-366 ENDIF C *** NRZ END LDAY=IDATE+DAYBEG-1 !WB current day = date counter + beg. day -1 DO 5580 JK=1,ICR !WB do this loop from the counter JK=1 to # cropping practices !RZ URBAN:::if the crop type is urban, none of these variables need to be calculated. !RZ So skip to the end of the loop and do the next crop. IF (URBCR.LE.ICR) GO TO 5580 !RZ URBCR is the number of urban crops, read in XDATA subroutine. *LDATE REPRESENT GROWTH DURATION LDATE=(DATHAR(JK)-DATPLA(JK))+1 !WB growth duration = (harvest date of cropping practice !WB - plant date of cropping practice) +1 RLENGT=(DATHAR(JK)-DATPLA(JK))/10. !WB unknown = (harv. date of crop practice - !WB plant date of crop practice) / 10 !WB This same line is defined differently a few lines above. !RZ See that !RZ definition for description of RLENGT. This redefinition almost seems like !RZ a mistake, leaving out the +1, especially because ldate is defined the same. !RZ this doesn't even seem to be used in the program after this point. LMODE=IDINT(((DBLE(LDAY)-DBLE(DATPLA(JK))+1)/DBLE(LDATE))*10)+1 IF(LMODE.GT.11) GOTO 5580 RMODE=((DBLE(LDAY)-DBLE(DATPLA(JK))+1)/DBLE(LDATE))*10.+1. IF(RMODE.LT.0.) THEN LMODE=IDINT(((DBLE(LDAY)-DBLE(DATPLA(JK))+366)/DBLE(LDATE))*10)+1 RMODE=((DBLE(LDAY)-DBLE(DATPLA(JK))+366)/DBLE(LDATE))*10.+1. ENDIF IF(LMODE.GT.10) GOTO 5580 IF(RMODE.LT.1) GOTO 5580 !WB LINE ADDED 1/19/99 TO PREVENT A NEGATIVE LAI1 WHEN LDAY IS LT !WB DATPLA. AT THE BEG OF A ROTATION, THIS CAUSES FLOAT ERRORS. LAI1(JK)=(LAI(JK,LMODE+1)-LAI(JK,LMODE))*(RMODE-LMODE) & +LAI(JK,LMODE) *COMPUTING THE ROOT DEPTH FOR A GIVEN DAY RDAYL=DBLE(LDAY)-DBLE(DATPLA(JK))+1. !WB = (current date - plant date) + 1 RDAYM=DBLE(DATHAR(JK))-DBLE(DATPLA(JK))+1. !WB = harvest date - plant date +1 ROTDAY(JK)=ROTMAX(JK)*(0.5+0.5*SIN(3.03*(RDAYL/RDAYM)-1.47)) !WB root depth for crop practice = max root depth for crop * !WB (0.5 + 0.5*sin(3.03*(fraction of root growth)-1.47)) !WB ***** SEDIMENT SUBROUTINE HEIGHT & CANOPY FACTORS **************** IF (LDATE.GT.365) THEN !WB A GENERAL ERROR CHECK FOR LONG ROTATIONS, WHICH AREN'T HANDLED !WB BY THE PLANT GROWTH MODEL IN THE SEDIMENT ROUTINE WRITE (*,2595) PAUSE ENDIF HGTFACT(JK)=MAXPLHGT(JK)/(GROWFACT(JK)*LDATE) !WB This is the canopy growth factor, used in the Kican factor in the !WB sed submodel. It assumes linear growth of plant height and canopy, !WB during the first half of the growing period, then is equal to !WB the max height during the last half of the growth period. !WB maxPLhgt=maximum canopy height for a crop. AUCFACT(JK)=(AC(JK)/100)/(GROWFACT(JK)*LDATE) !WB This is the Area Under Canopy factor, used in the Kican factor in !WB the sed submodel. It assumes linear growth of plant canopy, and !WB that max canopy is obtained at halfway through the growth period. !WB ERROR MESSAGES DDRTFAC(JK)=(DDROOTF(JK)-DDROOTI(JK))/(LDATE) LRFAC(JK)=(LIVEROOT(JK)/(GROWFACT(JK)*LDATE)) INRFACT(JK)=(INRCOVF(JK)-INRCOVI(JK))/(LDATE) IF ((DDRTFAC(JK).LT.-1).OR.(DDRTFAC(JK).GT.1)) THEN WRITE (2,3050) DDRTFAC(JK), JK WRITE (*,2592) PAUSE STOP ENDIF IF ((LRFAC(JK).LT.0).OR.(LRFAC(JK).GT.1)) THEN WRITE (2,3052) LRFAC(JK),JK WRITE (*,2592) PAUSE STOP ENDIF IF ((GROWFACT(JK).LT.0).OR.(GROWFACT(JK).GT.1)) THEN WRITE (2,2582) GROWFACT(JK) WRITE (*,2592) STOP ENDIF IF ((MAXPLHGT(JK).LT.0).OR.(MAXPLHGT(JK).GT.3.0)) THEN WRITE (2,2584) MAXPLHGT(JK) WRITE (*,2592) STOP ENDIF IF ((HGTFACT(JK).LT.0).OR.(HGTFACT(JK).GT.1)) THEN WRITE (2,2586) HGTFACT(JK) WRITE (*,2592) STOP ENDIF IF (((AC(JK)/100).LT.0).OR.((AC(JK)/100).GT.1)) THEN WRITE (2,2588) AC(JK) WRITE (*,2592) STOP ENDIF IF ((AUCFACT(JK).LT.0).OR.(AUCFACT(JK).GT.1)) THEN WRITE (2,2590) AUCFACT(JK) WRITE (*,2592) STOP ENDIF !WB END ERROR MESSAGES !WB ***** END SEDIMENT SUBROUTINE HEIGHT & CANOPY FACTOR *************** 5580 CONTINUE RAITES=0 !WB raintest flag, 0 = false, no storm RNUT=0 !WB nutrient application flag, 0 = no nutrient app DO 5581 JK1=1,ICR !WB do this loop from counter JK1 up to # of cropping practices RNUTNI(JK1)=0. !WB nitrate fertilizer applied to cropping practice RNUTAM(JK1)=0. !WB ammonium fertilizer applied to cropping practice RNUTP(JK1)=0. !WB P fert applied to cropping practice 5581 CONTINUE C *** NRZ 9/12/94 C *** MODIFIED FERTILIZER INPUT !WB****this is where raites is read, see if-then loop #699*********** READ(8,5560) TEMPC,SOITEM,RADI,RAITES !WB TEMPC = air temp, SOITEM = soil temp, RADI = daily radiation, !WB RAITES = raintest flag IF ((IDATE.EQ.1).AND.(IFERT.EQ.1)) THEN !WB if day = first day and fert. app = 1, then READ (9,*) !WB read from fertilizer.inp file READ (9,*) READ (9,6010) NFYEAR,NFDAY,NICR,TMPNI(NICR), & TMPAM(NICR),TMPP(NICR) !WB NFYEAR = year of fert. app., NFDAY = day of fertilizer app., !WB NICR = crop # to which fert is app'ed., TMPNI = amt of NO3 !WB aplied to crop i, TMPAN = amount of NH4 fert app to crop i, !WB TMPP = amt of P fert app'ed to crop i, 5583 ENDIF 5584 IF ((NFYEAR.EQ.YERBEG).AND.(NFDAY.EQ.LDAY)) THEN !WB if year of fert app equals beginning year and fert app day = !WB today, then !RZ yerbeg is the current year, not the beginning year - it is !RZ incremented every year NFPR = 1 !WB unknown; RZ: this is a flag to tell the output that this is a !RZ fertilizer day and thus 'fertilizing...' needs to be written !RZ to the screen RNUTNI(NICR)=TMPNI(NICR)*CONFAY !WB nitrate applied to crop i = amt NO3 app'ed to crop i * !WB DX^2 / 10000 RNUTAM(NICR)=TMPAM(NICR)*CONFAY !WB NH4 applied to crop i = amt of NH4 app'ed to crop i * !WB DX^2 / 10000 RNUTP(NICR)=TMPP(NICR)*CONFAY !WB P applied to crop i = amt of P app'ed to crop i * DX^2 / 10000 READ (9,6010,END=5585) NFYEAR,NFDAY,NICR,TMPNI(NICR), & TMPAM(NICR),TMPP(NICR) !WB The END statement in the read command above says to return !WB control to the executable statement when the end of file record !WB is reached, otherwise the program will return an error message. !WB This one says to read all the fert app data. !RZ This only goes until the IF THEN statement at 5584 is not satisfied; !RZ This makes sure that if more than one crop gets applied to on one day !RZ the program figures it out. Once you get an nfyear and nfday that !RZ are not today, you will jump to the end if after the goto statement and !RZ proceed on to the rest of the program without reading the rest of the input !RZ file. Contrary to what you might think reading WB's comments, putting an !RZ END= clause in your read statement does not make it a do loop. !RZ NFYEAR and NFDAY are stored for the next day; notice that IF THEN ending at !RZ 5583 is not executed except the first day of simulation; therefore, the test !RZ at 5584 will be executed on the last NFYEAR and NFDAY read until it is satisfied. GOTO 5584 ENDIF C *** NRZ 9/12/94 5585 PREMOI=0. !WB unknown PREPIV=0. !WB unknown *CHOOSE THE CORRECT COVER FOR THE GIVEN DAY LDYEAR=YERBEG*1000+LDAY !WB = beginning year of sim * 1000 + the day # DO 5588 J=1,N !WB do this loop from the counter J until the number of overland !WB flow elements K=MOD(SOIL(J),256) !WB K = soil - INT(SOIL / 256) * 256, this is the rotation # for !WB the overland flow element !TMN DO 5587 J1111=3,29,2 ! CHANGED TO 322 TO ACCOMODATE 322 ROTATION !TMN END DATES DO 5587 J1111=3,322,2 !WB DO 5587 J1111=3,21,2 !changed count to 29 b/c 28 rotation dates !WB J1111 is a count from 3 to 21 by 2 IF(LDYEAR.LE.IROT(K,J1111)) THEN !WB If the LDYEAR variable is less than or equal to the end date for !WB cover for a specific rotation (surf. type, J1111 matrix) INTI=IROT(K,J1111-1) !WB INTI = cover for rotation at beginning of rotation period SUR(J)=K*256+IROT(K,J1111-1) !WB surf. type = rotation # of current element * 256 + cover for !WB beginning of rotation period DAYNOW(J)=MOD(LDYEAR,1000) !WB THE JULIAN DAY TODAY=LDYEAR-INT(LDYEAR/1000)*1000 YEARNOW(J)=INT(LDYEAR/1000) !WB THE YEAR NOW=INTEGER(LDYEAR/1000) DYYRNOW(J)=(YEARNOW(J)*365+DAYNOW(J)) !WB THE # OF DAYS=YEAR # * 365 (DAYS/YEAR) + DAY # NOW IF (J1111.GT.3) THEN !WB IF THIS IS NOT THE FIRST INPUT ROTATION BEGROTDT(J)=IROT(K,J1111-2)+1 !WB THE END DATE OF THE PREVIOUS ROTATION (=BEG DATE OF THIS ROTATION) DAYTHEN(J)=MOD(BEGROTDT(J),1000.) !WB THE DAY # AT THE BEGINNING OF THIS CROP/COVER YEARTHEN(J)=INT(BEGROTDT(J)/1000.) !WB THE YEAR # AT THE BEGINNING OF THIS CROP/COVER ELSE DAYTHEN(J)=DATPLA(INTI) IF (DAYNOW(J).GE.DATPLA(INTI)) THEN YEARTHEN(J)=YEARNOW(J) ELSE YEARTHEN(J)=YEARNOW(J)-1 ENDIF ENDIF DYYRTHEN(J)=(YEARTHEN(J)*365+DAYTHEN(J)) !WB THE # OF DAYS AT THE BEGINNING OF THIS CROP/COVER DAYDIFF(J)=DYYRNOW(J)-DYYRTHEN(J) !WB THE DIFFERENCE IN # OF DAYS (NOW-BEGINNING DATE OF CROP/COVER) !TMN IF (DAYDIFF(J).GT.10000) DAYDIFF(J)=0. !TMN CHANGED TO ALLOWED MAX ROTATION LENGTH TO BE 100 YEARS !TMN (ACCOUNTED FOR LEAP YEARS) IF (DAYDIFF(J).GT.36525) DAYDIFF(J)=0. !WB THIS MAKES MAXIMUM ROTATION LENGTH FOR A SINGLE CROP !WB = 27 YEARS, 145 DAYS, BUT IS INTENDED TO PREVENT AN ERROR !WB OCCURRING WHEN THE FIRST ROTATION PARAMETER IS READ IF (DAYDIFF(J).LT.0) THEN WRITE (*,2594) STOP ENDIF GOTO 5588 ENDIF 5587 CONTINUE 5588 CONTINUE DO 6001 J=1,N !WB do this one from the counter J=1 to # of overland flow elements K=MOD(SOIL(J),256) !WB rotation # for current element = soil type for element i - !WB INT(soil type for i / 256) * 256 !TMN DO 6001 J1111=3,27,2 ! CHANGED TO 301 TO ACCOMODATE 301 !TMN ROTATION END DATES DO 6001 J1111=3,301,2 !WB DO 6001 J1111=3,19,2 changed count to 27 to represent 28 end dates !WB J1111 is a count from 3 to 19 by 2 IF(LDYEAR.EQ.(IROT(K,J1111)+1)) THEN !WB if the LDYEAR formula equals 1st day of the next period !WB of sim/cover SUMLAI(IROT(K,J1111+1))=0. !WB sum of LAI for the next (from J1111) cover/period is reset to 0 LAI1(IROT(K,J1111+1))=0. !WB LAI of the next (from J1111) cover/period = 0 INTI=IROT(K,J1111+1) !WB initial cover = cover at next (from J1111) period INTPREV=IROT(K,J1111-1) !WB previous cover = cover at previous (from J1111) period !RZ URBAN:: if the cover type is urban, then there is no dmy, yp, or cp1 IF (CROP(INTPREV,1).EQ.' URB') GO TO 6002 RES(INTI)=DMY(INTPREV)*YP(INTPREV)*CP1(INTPREV) 1 *0.25/100.*CONFAY !WB nitrogen in residue at beg of cover period = !WB dry matter ratio * yield potential * exponent for nitrogen !WB content * 0.25 / 100 * DX^2 / 10000 RES20(INTI)=RES(INTI)*0.80 !WB = nitrogen in residue at rotation at end of period !WB * 0.80 RES90(INTI)=RES(INTI)*0.10 !WB = nitrogen in residue at rotation at end of period !WB * 0.10 !WB INTI=IROT(K,J1111+1)-1 !WB RES(INTI+1)=DMY(INTI)*YP(INTI)*CP1(INTI)*0.25/100.*CONFAY !WB RES20(INTI+1)=RES(INTI+1)*0.80 !WB RES90(INTI+1)=RES(INTI+1)*0.10 !WB THE PREVIOUS 4 LINES WERE REMOVED 1/6/99 AND REPLACED BY THE LINES !WB ABOVE. THEY WERE REPLACED BECAUSE WHEN THE COVER # WAS A 1, THE !WB INTI VARIABLE RETURNED A 0, AND THE RES VARIABLE EXCEEDED ARRAY !WB BOUNDARIES IN THE CALCULATION. I BELIEVE THE COVER CHOICE TO BE !WB ERRONEOUS AS PREVIOUSLY WRITTEN BECAUSE IT DIDN'T CALCULATE RES AT !WB THE PREVIOUS COVER, IT CALCULATED IT FOR CURRENT COVER # MINUS 1. GOTO 6002 ENDIF 6001 CONTINUE 6002 J=MOD(SUR(19),256) !WB J = surface type on element 19 - INT (same / 256) * 256 !RZ surface type JAD=MOD(LDAY,60) !THIS LINE IS USED NOWHERE-FWB !WB = Day # - INT (Day # / 60) * 60 C IF(JAD.EQ.0) WRITE(6,*) 'SIMULATING ', YERBEG,LDAY C **** NRZ (11/4/94) C **** NEW SCREEN OUTPUT IF (IIRRI.EQ.1) THEN IRRIGAT=1 DUMMY=0. CALL IRRIGATE(LDAY,RAITES,YERBEG,IDATE,IRRIGAT,ICR,DUMMY,TMAX, 1JJ,ITR,CU,N,CU1,DT) END IF !RZ call the irrigation subroutine if the irrigation flag is triggered !RZ in answers.inp. Set irrigat to 1 to indicate we are executing the first !RZ part of the subroutine. Dummy is a placeholder for a variable not !RZ defined yet but that needs to be passed at the next subroutine call. ! WRITE (377,*) (1-PIV(1)*DT/TP1(INT(SOIL(1)/256))), LDAY CALL XDATE (LDAY,YERBEG,IDATE,SIMDUR,RAITES,NFPR,IRRFLAG) !WB LDAY = day #, YERBEG = beginning year of simulation, !WB IDATE = date of simulation, SIMDUR = simulation duration, !WB RAITES = raintest flag, NFPR = fertilizer flag, IRRFLAG= irrigation flag C **** NRZ 11/4/94) !WB ****** BEGINNING OF NEW SEDIMENT INITIALIZATION SCHEME ********** IF (INIT.EQ.0) THEN !WB THIS LOOP IS A PAGE OR SO LONG, AND THE INIT=0 VARIABLE IS INITIAL- !WB IZED ABOVE WITH WIDINC & DEPTHINC. IT IS DESIGNED TO ONLY ALLOW !WB THE BASELINE VALUES TO INITIALIZE ONCE. !WB THE ROUTINE MUST BE PLACED HERE B/C IT RELIES ON CORRECT CHOICE OF !WB COVER CONDITIONS FOR CALCULATION OF OTHER VAR'S. INIT=1 !WB The following do loop converts the soil parameters from percentage !WB quantities to fractional quantities. DO 9200 CNT=1,ISR !RZ URBAN::if the soil type is urban, these parameters do not need to be set IF (URBSOIL(CNT).EQ.1) GO TO 9200 CLAY(CNT)=CL(CNT)/100 SAND(CNT)=SA(CNT)/100 SILT(CNT)=ST(CNT)/100 ORGMAT(CNT)=OM(CNT)/100 MASSCF(CNT)=WCF(CNT)/100 VFS(CNT)=VFSPER(CNT)/100 BULKDENS(CNT)=BD(CNT)*1000 !WB BULKDENS=SOIL BULK DENSITY IN KG*M-3 IF ((CLAY(CNT).LT.0).OR.(SAND(CNT).LT.0).OR.(SILT(CNT).LT.0).OR. 1(ORGMAT(CNT).LT.0).OR.(MASSCF(CNT).LT.0).OR.(BULKDENS(CNT).LT.0) 2.OR.(VFS(CNT).LT.0)) 3 THEN WRITE (2,2596) CLAY(CNT),SAND(CNT),SILT(CNT),VFS(CNT),ORGMAT 1(CNT) WRITE (2,2597) MASSCF(CNT),BULKDENS(CNT),CNT WRITE (*,2592) STOP ENDIF IF ((CLAY(CNT).GT.1).OR.(SAND(CNT).GT.1).OR.(SILT(CNT).GT.1).OR. 1(ORGMAT(CNT).GT.1).OR.(MASSCF(CNT).GT.1).OR.(VFS(CNT).GT.1).OR. 2(BULKDENS(CNT).GT.5000)) THEN WRITE (2,2596) CLAY(CNT),SAND(CNT),SILT(CNT),VFS(CNT),ORGMAT 1(CNT) WRITE (2,2597) MASSCF(CNT),BULKDENS(CNT),CNT WRITE (*,2592) STOP ENDIF 9200 END DO N2=NN-1 DO 9210 CNT=1,N2 K=SOIL(CNT)/256 !WB THIS EXTRACTS THE SOIL TYPE JK=MOD(SUR(CNT),256) !WB jk extracts the crop descriptor # (cover type) HYDRADOLD(CNT)=0.1 !WB INITIALIZE A VAR HOLDER FOR HYDRAULIC RADIUS. SEE SUB SED IF (CNT.GT.N) THEN JK=21 NOTILL(JK)=1. ENDIF !RZ URBAN::if the soil type is urban, none of these calculations need to be made. The only !RZ calculation which could possibly pertain in an urban area is taurr and it is not used !RZ outside of this loop. Therefore, skip to end of loop if the soil is urban. IF (URBSOIL(K).EQ.1) GO TO 9210 IF (SAND(K).GE.0.30) THEN !WB sand(K)=fraction of sand in upper soil layer, VFS = fraction of !WB very fine sand in upper soil layer (very fine sand in WEPP !WB documentation) !WB orgmat=fraction of organic matter in upper soil layer, clay = !WB fraction of clay in the upper soil layer IF (VFS(K).LT.0.40) THEN VFSCALC=0.40 ELSE VFSCALC=VFS(K) ENDIF IF (ORGMAT(K).LT.0.0035) THEN OMCALC=0.0035 ELSE OMCALC=ORGMAT(K) ENDIF KRBASE(CNT)=0.00197+0.030*VFSCALC+0.03863* 1 exp(-184*OMCALC) !WB Krbase = baseline rill erodibility IF (CLAY(K).GE.0.40) THEN CLAYCALC=0.40 ELSE CLAYCALC=CLAY(K) ENDIF TAUCB(CNT)=2.67+6.5*CLAYCALC-5.8*VFSCALC !WB taucb = baseline critical shear ENDIF IF (SAND(K).LT.0.30) THEN IF (CLAY(K).LT.0.10) THEN CLAYCALC=0.10 ELSE CLAYCALC=CLAY(K) ENDIF KRBASE(CNT)=0.0069+0.134*exp(-20*CLAYCALC) TAUCB(CNT)=3.5 ENDIF IF (KRBASE(CNT).GT.0.05) THEN !WB THESE ARE LIMITS SUGGESTED BY WEPP DOCUMENTATION WRITE (*,2598) CNT,KRBASE(CNT) WRITE (2,2598) CNT,KRBASE(CNT) KRBASE(CNT)=0.05 PAUSE ENDIF IF (KRBASE(CNT).LT.0.002) THEN WRITE (*,3000) CNT,KRBASE(CNT) WRITE (2,3000) CNT,KRBASE(CNT) KRBASE(CNT)=0.002 PAUSE ENDIF IF (TAUCB(CNT).GT.7.0) THEN !WB LIMITS SUGGESTED BY WEPP WRITE (*,3002) CNT,TAUCB(CNT) WRITE (2,3002) CNT,TAUCB(CNT) TAUCB(CNT)=7.0 PAUSE ENDIF IF (TAUCB(CNT).LT.0.3) THEN WRITE (*,3004) CNT,TAUCB(CNT) WRITE (2,3004) CNT,TAUCB(CNT) TAUCB(CNT)=0.3 PAUSE ENDIF IF (CNT.LE.N) THEN !WB SKIP THE RANDOM ROUGHNESS ADJUSTMENT IF ITS A CHANNEL CELL, B/C !WB THE RANROU IS A FUNCTION OF TILLAGE PROP'S IF ((RANROUM(JK).LT.0.00099).AND.(RANROUM(JK).NE.0)) THEN !WB 'RANROU INPUT IN METERS' ERROR STATEMENT WRITE (2,3006) RANROUM(JK) WRITE (*,3006) RANROUM(JK), JK PAUSE ENDIF IF (RANROUM(JK).LE.0.006) RANROUM(JK)=0.006 !WB INPUT A VALUE OF 0 FOR A PASTURE SITUATION WILL RESULT IN TAURR = 1 TAURR(CNT)=1.0+8.0*(RANROUM(JK)-0.006) !WB taurr=random roughness adjustment, where ranroum = random roughness !WB in m IF (TAURR(CNT).GT.2.552) THEN !WB This corresponds to a random roughness in excess of 200 mm. WRITE (2,3008) TAURR(CNT),CNT WRITE (*,3008) TAURR(CNT),CNT PAUSE ENDIF ELSE !WB ELSE GOES WITH THE IF CNT.LE.N; IF ITS A CHANNEL CELL, TAURR=1 TAURR(CNT)=1 ENDIF TAUCHLD(CNT)=TAUCB(CNT)*TAURR(CNT) !WB tauchld(M) is a variable to "hold" the adjusted critical shear, !WB where taucb is calculated IF (CNT.GT.N) GO TO 9205 !WB SKIP THE BASELINE INTERRILL ERODIBILITY CALC IF THIS IS A CHANNEL !wb CELL !WB Calculate the baseline interrill erodibility parameter, Kibase IF (SAND(K).GE.0.30) THEN IF (VFS(K).GE.0.40) THEN VFSCALC=0.40 ELSE VFSCALC=VFS(K) ENDIF KIBASE(CNT)=2728000+19210000*VFSCALC !WB BASELINE INTERRILL ERODIBILITY ENDIF IF (SAND(K).LT.0.30) THEN IF (CLAY(K).LT.0.10) THEN CLAYCALC=0.10 ELSE CLAYCALC=CLAY(K) ENDIF KIBASE(CNT)=6054000-5513000*CLAYCALC ENDIF !WB The adjusted interrill erodibility parameter is: !WB Kiadj=Kibase*Kican*Kigrcov*Kisc where Kibase = baseline interrill !WB erodibility, Kican = canopy height adjustment, Kigrcov = ground !WB ground cover adjustment, Kisc = sealing and crusting adjustment. !WB Because these variables are expected to change throughout the season, !WB they are calculated on a daily basis. IF (KIBASE(CNT).GE.12000000) THEN !WB LIMITS SUGGESTED BY WEPP WRITE (*,3010) CNT,KIBASE(CNT) WRITE (2,3010) CNT,KIBASE(CNT) KIBASE(CNT)=12000000 PAUSE ENDIF IF (KIBASE(CNT).LT.500000) THEN WRITE (*,3012) CNT,KIBASE(CNT) WRITE (2,3012) CNT,KIBASE(CNT) KIBASE(CNT)=500000 PAUSE ENDIF 9205 CONTINUE 9210 ENDDO ENDIF !WB END OF INIT=0 'LOOP' !WB ******* END OF NEW SED SUBROUTINE INITIALIZATION *************** ***********************if then loop #699************************ DO M=1,N2 IF (POND(M).GT.0) THEN IF(CALLBMP(M).EQ.1) THEN IF(SUB(POND(M)).EQ.0) THEN IF((((H2ODEPTH(POND(M)).GT.ORBOT(POND(M))).AND. 1 (TIPE(POND(M)).EQ.1))).OR.(((H2ODEPTH(POND(M)).GT. 2 RISH(POND(M))).AND.(TIPE(POND(M)).EQ.2)))) THEN BMPFLAG=1 END IF END IF END IF END IF END DO !RZ URBAN::if the volume of water in a cell is greater than the orifice bottom !RZ (i.e., outflow to other elements may occur and must be tracked), set the !RZ flag so the next if then will be satisfied and execution will continue ! IF (RAITES.EQ.1) THEN !RZ if raintest=1 then !WB this if then loop goes for several pages, look for program !WB marker # 2611 !RZ URBAN:: changed 8/13/01: make this loop go for irrigation days too !RZ or for days when the height of water in a bmp is greater than 0 IF ((RAITES.EQ.1).OR.(IRRFLAG.EQ.1).OR.(BMPFLAG.EQ.1)) THEN IF ((RAITES.EQ.0.).AND.(BMPFLAG.EQ.1)) THEN WRITE(*,*) ' ...Draining Pond' !RZ This if-then initializes stuff to zero that rainfa would !RZ normally have done. AINO3(CHOUT(1))=0. AINH4(CHOUT(1))=0. SPI(CHOUT(1))=0. DO IC=1,NPART SI(CHOUT(1),IC)=0. PI(CHOUT(1),IC)=0. ANI(CHOUT(1),IC)=0. ONI(CHOUT(1),IC)=0. END DO DO I=1,N2 SS(I)=0. SEL(I)=0. NO3SEL(I)=0. NHWSEL(I)=0. NHSSEL(I)=0. TKNSEL(I)=0. PO4SEL(I)=0. PSEL(I)=0. END DO END IF !WB ******* BEGIN SEDIMENT SUBROUTINE DAILY CALC'S ************** !WB The # of days since last soil disturbance is approximated by !WB DAYDIFF, which is the current day - the planting day !WB for the crop in the current rotation. DO 9305 CNT=1,N2 K=SOIL(CNT)/256 !wb K extracts the soil type # JK=MOD(SUR(CNT),256) !WB jk extracts the crop descriptor # (cover type) IF (CNT.GT.N) THEN JK=21 NOTILL(JK)=1 LRFAC(JK)=0. DDROOTI(JK)=0. DDRTFAC(JK)=0. ENDIF !RZ above sets values for channel cells and gives channel cells a crop type 21 !RZ (which is higher than the maximum 20 crop types) !RZ URBAN:::following check skips the sediment calculations if the cell is urban IF (URB(CNT).EQ.1) THEN ! URBAN=5 ! IDUMMY=0 ! CALL URBANIZED(URBAN,IDUMMY,IDUMMY,ADUMMY,IDUMMY,IDUMMY,IDUMMY !! 1,IDUMMY,CNT,IDUMMY,IDUMMY,IDUMMY,DUMMY,DUMMY,ADUMMY,DUMMY,DUMMY, ! 2DUMMY,DUMMY,DUMMY,IDUMMY,IDUMMY,IDUMMY,ADUMMY,ADUMMY) GOTO 9304 END IF IF (CNT.LE.N) THEN !WB SKIP THIS SECTION IF IT'S A CHANNEL CELL IF (DAYDIFF(CNT).EQ.0) THEN IF (NOTILL(JK).EQ.0) MAXWID=0.0000001 ENDIF ENDIF !WB THIS SAYS THAT IF THE DAYDIFF=0, A ROTATION HAS JUST BEEN CHANGED, !WB AND THEREFORE PREVIOUS RILLS HAVE BEEN DESTROYED, AND NEW RILLS !WB MUST BE TRACKED. KRCONS(CNT)=0.00035-0.0014*FCFRAC(K)+0.00068*SILT(K) 1+0.0049*MASSCF(K) !WB This is a soil consolidation factor for use in the sealing and !WB crusting adjustment equation. IF (FCFRAC(K).GT.1) THEN WRITE (2,3014) FCFRAC(K),K WRITE (*,2592) STOP ENDIF IF ((KRCONS(CNT).LT.0.).OR.(KRCONS(CNT).GT.1.)) THEN WRITE (2,3016) KRCONS(CNT),CNT WRITE (*,2592) STOP ENDIF IF ((CNT.GT.N).OR.(NOTILL(JK).EQ.1)) THEN KRSC(CNT)=(KRCONS(CNT)/KRBASE(CNT)) ELSE KRSC(CNT)=(KRCONS(CNT)/KRBASE(CNT))+(1-(KRCONS(CNT)/KRBASE(CNT)))* 1exp(-BD(K)*DAYDIFF(CNT)) !WB Krsc=sealing and crusting adjustment for rill erodibility. It is !WB dependent upon the # of days since soil disturbance. The quantity !WB (DAYDIFF(CNT)) is the # of days since planting, which will be !WB the last assumed day of disturbance. ENDIF IF ((KRSC(CNT).LT.0).OR.(KRSC(CNT).GT.1)) THEN WRITE (2,3018) KRSC(CNT),CNT WRITE (*,2592) STOP ENDIF IF ((CNT.LE.N).OR.(NOTILL(JK).EQ.0)) THEN !WB IF ITS A O.F. CELL OR A CONV TILLAGE, CALC BURIED RES ADJUSTMENT BURRES(JK)=BR(JK)*exp(-0.010181*DAYDIFF(CNT)) !WB THIS FACTOR BASED ON THE WORK OF BROWN, FOSTER, BEASLEY, 60% !WB REDUCTION OVER 90 DAY PERIOD LN 0.4 / -90 = 0.010181 KRBR(CNT)=exp(-0.4*BURRES(JK)) !WB Krbr = adjustment for buried residue, where br(M) is the !WB mass of buried residue (kg m-2) w/in 0 to 0.15 m of the soil zone ENDIF IF ((CNT.GT.N).OR.(NOTILL(JK).EQ.1)) THEN !WB IF CHANNEL CELL OR NOTILL COVER, SET THE BURIED RESIDUE FACTOR=1. KRBR(CNT)=1. ENDIF IF ((KRBR(CNT).LT.0).OR.(KRBR(CNT).GT.1)) THEN WRITE (2,3005) KRBR(CNT) WRITE (*,2592) STOP ENDIF TAUCONS(CNT)=8.37-11.8*FCFRAC(K)-4.9*SAND(K) !WB This is a consolidation adjustment for the baseline critical shear. IF ((CNT.GT.N).OR.(NOTILL(JK).EQ.1)) THEN TAUSC(CNT)=(TAUCONS(CNT)/TAUCB(CNT)) ELSE TAUSC(CNT)=(TAUCONS(CNT)/TAUCB(CNT))+(1-(TAUCONS(CNT)/TAUCB(CNT))) 1*exp(-BD(K)*DAYDIFF(CNT)) !WB tausc=sealing and crusting adjustment for critical shear. END IF TAUCADJ(CNT)=TAUCHLD(CNT)*TAUSC(CNT) !WB taucadj=adjusted critical shear calculated in the initialization of !WB the program * sealing and crusting adjustment. IF ((TAUCONS(CNT).LT.0.).OR.(TAUCADJ(CNT).GT.15)) THEN WRITE (*,3030) TAUCONS(CNT),CNT WRITE (2,3030) TAUCONS(CNT),CNT STOP ENDIF IF (CNT.GT.N) GO TO 9300 !WB THIS SKIPS THE INTERRILL CALCS IF YOU ARE CALCULATING CHANNEL !WB EROSION. HEIGHT(JK)=HGTFACT(JK)*(DAYDIFF(CNT)+1) !WB the height at this day = the height factor * the # of days since !WB planting. The daydiff +1 is added to avoid a div by 0 error below. CANOPY(JK)=AUCFACT(JK)*(DAYDIFF(CNT)+1) !WB the canopy area at this day = canopy factor * the # of days since !WB planting IF (HEIGHT(JK).GT.MAXPLHGT(JK)) HEIGHT(JK)=MAXPLHGT(JK) IF (CANOPY(JK).GT.(AC(JK)/100)) CANOPY(JK)=(AC(JK)/100) IF ((HEIGHT(JK).GT.3.0).OR.(CANOPY(JK).GT.1.)) THEN WRITE (*,3032) CNT WRITE (2,3032) CNT PAUSE ENDIF !WB IF THE HEIGHT EXCEEDS THE MAXIMUM PLANT HEIGHT, OR CANOPY EXCEEDS !WB ITS INPUT MAX VALUE, THEN !WB height=maximum height and canopy=maximum canopy IF (HEIGHT(JK).NE.0) THEN !WB ADDED TO ELIMINATE DIV BY 0 KICAN(CNT)=1-2.941*(CANOPY(JK)/HEIGHT(JK))* 1(1-exp(-0.34*HEIGHT(JK))) !WB Kican=canopy height adjustment factor. CANOPY IS THE FRACTION OF !WB GROUND COVERED BY CANOPY AT THIS DAY, HEIGHT IS PLANT HEIGHT AT !WB THIS DAY. CANOPY & HEIGHT ARE LINEAR FUNCTIONS OF THEIR MAX VALUES. ELSE KICAN(CNT)=1 ENDIF IF ((KICAN(CNT).LT.0).OR.(KICAN(CNT).GT.1)) THEN IF (KICAN(CNT).LT.0) THEN WRITE (2,3034) KICAN(CNT),CNT WRITE (*,2592) STOP ELSE IF (KICAN(CNT).GT.1) THEN WRITE (2,3034) KICAN(CNT),CNT WRITE (*,3034) KICAN(CNT),CNT PAUSE ENDIF ENDIF ENDIF INRCOV(JK)=INRCOVI(JK)+(INRFACT(JK)*(DAYDIFF(CNT)+1)) !WB inrcov=fraction of interrill area covered by ground cover IF (INRFACT(JK).GT.0) THEN !WB IF COVER INCREASES IF (INRCOV(JK).GT.INRCOVF(JK)) INRCOV(JK)=INRCOVF(JK) !WB IF THE CALC INT COV EXCEEDS THE FINAL VALUE INPUT, SET THEM EQUAL ELSE !WB IF COVER DECREASES IF (INRCOV(JK).LT.INRCOVF(JK)) INRCOV(JK)=INRCOVF(JK) !WB IF THE COVER DROPS BELOW THE FINAL VALUE, SET THEM EQUAL ENDIF IF (INRCOV(JK).GT.1) THEN INRCOV(JK)=1. WRITE (2,3036) INRCOV(JK),JK WRITE (*,2592) INRCOV(JK),JK PAUSE ENDIF IF (INRCOV(JK).LT.0) THEN WRITE (2,3049) INRCOV(JK), JK WRITE (*,2592) PAUSE STOP ENDIF KIGRCOV(CNT)=exp(-2.5*INRCOV(JK)) !WB kigrcov=ground cover adjustment factor, which is a function of crop !WB crop properties. Inrcov is the fraction of interrill area covered !WB by ground cover. IF ((KIGRCOV(CNT).LT.0).OR.(KIGRCOV(CNT).GT.1)) THEN IF (KIGRCOV(CNT).LT.0) THEN WRITE (2,3038) KIGRCOV(CNT),CNT WRITE (*,2592) STOP ELSE IF (KIGRCOV(CNT).GT.1) THEN WRITE (2,3038) KIGRCOV(CNT),CNT WRITE (*,3038) KIGRCOV(CNT),CNT PAUSE ENDIF ENDIF ENDIF KICONS(CNT)=1000*(3042-3166*SAND(K)-8816*ORGMAT(K)-2477* 1FCFRAC(K)) !WB Kicons=consolidation adjustment for sealing and crusting adjustment !WB to the interrill erodibility. IF (KICONS(CNT).LT.0) THEN WRITE (2,3040) SAND(K),ORGMAT(K),FCFRAC(K) WRITE (*,2592) PAUSE STOP ENDIF IF (NOTILL(JK).EQ.1) THEN KISC(CNT)=(KICONS(CNT)/KIBASE(CNT)) ELSE KISC(CNT)=(KICONS(CNT)/KIBASE(CNT))+(1-(KICONS(CNT)/KIBASE(CNT))) 1*exp(-BD(K)*DAYDIFF(CNT)) !WB Kisc=interill sealing and crusting adjustment. DAYDIFF(CNT) is !WB the # of days since disturbance. ENDIF IF ((KISC(CNT).LT.0).OR.(KISC(CNT).GT.1)) THEN IF (KISC(CNT).LT.0) THEN WRITE (2,3042) KISC(CNT),CNT WRITE (*,2592) STOP ELSE IF (KISC(CNT).GT.1) THEN WRITE (2,3042) KISC(CNT),CNT WRITE (*,3042) KISC(CNT),CNT PAUSE ENDIF ENDIF ENDIF 9300 CONTINUE !WB AFTER THE INCLUSION OF THE DEAD AND LIVE ROOT FACTORS FOR !WB RILL AND INTERRILL ERODIBILITY ADJUSTMENT, THE ADJUSTED !WB RILL ERODIBILITY HAD TO BE CALCULATED HERE, BECAUSE !WB THE LIVE AND DEAD ROOT FACTORS ARE CALCULATED HERE. !WB AN IF-THEN STATEMENT SKIPS THE INTERRILL ERODIBILITY ADJUSTMENT LROOT(JK)=LRFAC(JK)*(DAYDIFF(CNT)+1) IF (LROOT(JK).GT.LIVEROOT(JK)) LROOT(JK)=LIVEROOT(JK) KLROOTI(CNT)=EXP(-0.56*LROOT(JK)) IF ((KLROOTI(CNT).LT.0).OR.(KLROOTI(CNT).GT.1)) THEN WRITE (2,3058) KLROOTI(CNT),JK,CNT WRITE (*,2592) PAUSE STOP ENDIF DROOT(JK)=DDROOTI(JK)+DDRTFAC(JK)*(DAYDIFF(CNT)+1) IF (DROOT(JK).LT.DDROOTF(JK)) THEN DROOT(JK)=DDROOTF(JK) ENDIF KDROOTI(CNT)=EXP(-0.56*DROOT(JK)) IF ((KDROOTI(CNT).LT.0).OR.(KDROOTI(CNT).GT.1)) THEN WRITE (2,3060) KDROOTI(CNT),JK,CNT WRITE (*,2592) PAUSE STOP ENDIF IF (CNT.LE.N) THEN !WB IF IT'S AN O.F. CELL, DO THE KIADJ CALC KIADJ(CNT)=KIBASE(CNT)*KICAN(CNT)*KIGRCOV(CNT)*KISC(CNT) 1*KLROOTI(CNT)*KDROOTI(CNT) !WB Kiadj=adjusted interrill erodibility parameter. IF (KIADJ(CNT).LT.0) THEN WRITE (2,3044) KIADJ(CNT),CNT WRITE (*,2592) STOP ENDIF ENDIF KLROOTR(CNT)=EXP(-3.5*LROOT(JK)) IF ((KLROOTR(CNT).LT.0).OR.(KLROOTR(CNT).GT.1)) THEN WRITE (2,3054) KLROOTR(CNT),JK,CNT WRITE (*,2595) PAUSE STOP ENDIF KDROOTR(CNT)=EXP(-2.2*DROOT(JK)) IF ((KDROOTR(CNT).LT.0).OR.(KDROOTR(CNT).GT.1)) THEN WRITE (2,3056) KDROOTR(CNT),JK,CNT WRITE (*,2592) PAUSE STOP ENDIF KRADJ(CNT)=KRBASE(CNT)*KRSC(CNT)*KRBR(CNT)*KLROOTR(CNT) 1*KDROOTR(CNT) !WB This is the adjusted rill erodibility parameter, which is !WB initialized previously and recalculated here to include !WB consolidation with time. IF ((KRADJ(CNT).LT.0.).OR.(KRADJ(CNT).GT.1)) THEN IF (KRADJ(CNT).LT.0) THEN WRITE (2,3020) KRADJ(CNT),CNT WRITE (*,2592) STOP ELSE WRITE (2,3022) KRADJ(CNT),CNT WRITE (*,3022) KRADJ(CNT),CNT PAUSE ENDIF ENDIF 9304 CONTINUE 9305 END DO !WB ******* END OF SEDIMENT SUBROUTINE DAILY CALC'S ************** !RZ URBAN::IN THE NEXT FEW CALCULATIONS, THE PREMOI AND PREPIV ARE SUMMED UP AND THEN AFTER !RZ THE LOOP THEY ARE AVERAGED. TO GIVE AN ACCURATE AVERAGE, YOU PROBABLY SHOULD NOT INCLUDE !RZ THE URBAN CELLS IN THE DIVISOR, AS THEY FORCE ZEROS INTO THE TOTAL. SO, INITIALIZE A !RZ VARIABLE 'L' FOR A DIVISOR AFTER LINE 6000. L=0 !WB***************do loop # 717************************* DO 6000 J=1,N !WB do from counter J to # of overland flow elements !RZ URBAN::if the cell is urban, skip these calculations (no soil to hold moisture) IF (URB(J).EQ.1) GO TO 6000 K=SOIL(J)/256 !WB soil factor for element PIV(J)=(1.-(ASMVOL(J)+RESWAT(K))*CU1/TP1(K))*TP1(K)/DT !WB Volume of air filled pore space in upper layer = !WB (1 - (ASMVOL(flow element)+res. water as a fraction of !WB soil porosity) * conversion-mm to m^3 / soil porosity ) !WB * porosity / time increment ASMPER(J)=ASMVOL(J)*CU1/TP1(K) !WB unknown !RZ this is percent of the pore spaces filled = volume of water in soil*conversion/total porosity !RZ (done for every overland flow element, using the asmvol from outside the loop and tp1 !RZ dependent on soil type for the overland flow element) - as decimal !RZ on second thought, this is converting ASMVOL, which is in mm, to ASMPER, which is as a percent !RZ total porosity (like the percentages in the soil input file) PREMOI=ASMPER(J)+PREMOI !WB unknown !RZ seems to be summing up the percent moisture for each cell to !RZ give a pre-moisture for the watershed PREPIV=PREPIV+PIV(J) !WB unknown !RZ seems to be summing up the air-filled pore space percent for the watershed to give !RZ a pre-air filled pore space !RZ URBAN::INCREMENT THE DIVISOR (SEE NOTE ABOVE DO LOOP #717) L=L+1 6000 CONTINUE !WB***************end do loop # 717********************** !RZ PREMOI=PREMOI/N IF (L.GT.0) THEN PREMOI=PREMOI/L !RZ URBAN:: CHANGED THIS TO PREMOI=PREMOI/L so as not to warp the percent with noncontributing !RZ urban cells. !WB unknown !RZ this gives the average pre-moisture percent !RZ URBAN::CHANGED THIS TO PREPIV=PREPIV/L PREPIV=PREPIV/L !RZ PREPIV=PREPIV/N !WB unknown !RZ this gives the average pre-air filled pore space percent END IF !RZ URBAN::MAKE SURE THERE ARE VARIABLES FOR ALL THESE TO PASS FOR URBAN CELLS IF (RAITES.EQ.1) THEN 5570 CALL RAINFA(NRG,FILTS,PP,N,CU1,CU2,CU,DT,TMIN,TMAX,KPR,NDT, 1 ISTRUC,NMAX,ICR,NN,NCHAN,YERBEG,LDAY,DX,SOIVOL) !WB NRG = # of raingage, FILTS = infiltration cap., PP = !WB alphanumeric unit descriptor, N = # overland flow elements, !WB CU1 = conv. mm to m^3, CU2 = twice m^3, CU = mm/h to m^3 / s, !WB DT = time increment, TMIN = min time value of hyetograph, !WB TMAX = max time value of hyetograph, KPR = # of time !WB increment routings b/t print lines, NDT = # of lines of !WB hydrograph print, ISTRUC = structural practice counter !WB NMAX = maximum # of cells, ICR = # of cropping practices, !WB NN = N2 +1 (# of channel + # of overland flow elements + 1) C C **** COMPUTE THE PIECE-WISE LINEAR SEGMENTS FOR USE IN MANNING'S C **** EQUATION. C END IF SC=((SF*CONV/SB)**.6)/300. !WB depth incr. for segmented curve = [[seg. factor = max projected !WB catchment discharge * (conv mm/h to m/s / ave. overland flow !WB conveyance coefficient) ] ^0.6 ] / 300 D=0. !WB depth increment = 0 !WB************************do loop # 760******************** DO 10 I=1,300 QA(I)=D**1.66667 !WB incremental depth power values 10 D=D+SC !WB depth = depth + segmented curve depth increment !WB************************end do loop # 760**************** SC=1./SC !WB depth increment = inverse of depth increment *--* DX2=DX*DX !WB = length of side * length of side *--* C C **** INITIALIZE VARIABLES. C **** SET RAINFALL INITIAL VALUES. C !WB*********************do loop # 778*********************** DO 20 I=1,NRG !WB do from counter I = 1 to number of rain gages JTR(I)=1 !WB current rainfall intensity histogram period for rain gage i IF (TC(I,2).EQ.TMIN) JTR(I)=2 !WB if time of jth histogram period for gage i = min. time , !WB current rainfall int. histogram period = 2 SR(I)=0. !WB rainfall rate from prev. calculation 20 NF(I)=NFI !WB down counter = max # of time increments b/t infiltration recalculations !WB********************end do loop # 778******************** N1=N+1 !WB N1 = number of elements + 1 N2=NN-1 !WB reset N2 to # overland flow + # channel elements CHN=N2-N !WB # channel seg's = above - # of o.f. elements C C **** EROSION CONSTANTS. C IF (IT.LE.0) GO TO 30 !WB unknown C C **** METRIC UNITS. C !WB These can all be removed, 9/29/98 * CE1 and CE2 were not corrected because they are not * used anymore ! CE1=9.66155E+5 ! CE2=2.0847E+1 ! CE3=6.53864E+6 *these correction are made according to the Wisconsin *department of Natural resources, EPA final report (1986) !WB This can be removed also, 9/29/98 C **** NRZ 8/5/95 C **** CE3 was divided by 20. in order to examine difference in sediment C **** output. ! CE3=CE3/20. ! CE4=5.25545E+1 ! CE4=CE4 ! CE5=7.7419E-4 CE6=1.E+3 C C **** INITIALIZE VALUES. C C **** NRZ 9/14/94 C **** ADD DIMENSIONS FOR MULTIPLE CHANNEL OUTLETS !WB******************do loop # 836******************** 30 DO 25 NCH=1,NCHAN+1 !WB NCH is a channel counter, do from that until you equal the # of !WB channels + 1 VOL(NCH)=0. !WB accumulated runoff depth SSI(1,NCH)=0. !WB accumulated loss at print line i PSSI(1,NCH)=0.0 !WB accumulated sediment bound P-loss, line i for a given storm SPSSI(1,NCH)=0. !WB accum dissolved P loss ANSSI(1,NCH)=0. !WB accum sed-bound ammonium loss ANH4SI(1,NCH)=0. !WB accum dissolved ammonium loss ONSSI(1,NCH)=0. !WB accum sed. bound TKN loss ANO3SI(1,NCH)=0. !WB accum dissolved nitrate loss SSCON(1,NCH)=0. !WB sed conc at print line i RW(1,NCH)=0. !WB average rainfall intensity over catchment Q1(1,NCH)=0. !WB discharge from catchment at i 25 CONTINUE !WB************************end do loop # 836********************** BMPFLAG=0 !RZ reset the bmpflag to zero. This was moved here from right after the !RZ if raites.eq.1 test to accomodate the if then in the previous !RZ do loop (loop #836) but then I cut out the if-then, but it still !RZ works here so I just left it here SDR=0. !WB accum groundwater storage CHDR=0. !WB groundwater discharge into a channel segment RMAX=0. !WB MAX RAINFALL INTENSITY? QMAX=0. !WB MAX FLOW? CMAX=0. !WB MAX SEDIMENT? PREC=0. !WB accum depth of precip DTM=DT/60. !WB sim. time increment in minutes T(1)=TMIN !WB = min time value on hyetograph C **** NRZ 9/14/94 C C .... INITILIZATION OF DATA EXTENDED SED SUBROUTINE C ERG=0. !WB sum of all particle size classes leaving watershed !WB********************do loop # 888********************* DO 31 I1=1,8 !WB do this for the number of particle size classes? 31 ER(I1)=0. !WB amount of particle type i leaving watershed !WB********************end do loop # 888***************** YALCON=0.635 !WB Yalin's constant = 0.635 * * INITIALIZE VARIABLES FOR THE PHOSPHORUS COMPONENT * * TESPLA=0. !WB unknown TESNH4=0. !WB unknown TESNO3=0. !WB unknown !RZ above variables are used in the following loop to accumulate the nutrients !RZ in the EDI and then average them. !RZ URBAN:::variable L is used to count the number of non-urban cells - those that are !RZ actually contributing to the TES variables above - so that an accurate average !RZ can be taken after the termination of the loop. L=0 !WB********************do loop # 907************************ DO 32 M=1,N !WB do from element # counter, M, to the # of overland flow elements !RZ URBAN:::if cell is urban, skip this entire loop to avoid several !RZ divide by zeros. IF (URB(M).EQ.1) THEN URBAN=5 DUMMY=0. IDUMMY=0 CALL URBANIZED (URBAN,IDUMMY,IDUMMY,A1DUMMY,IDUMMY,IDUMMY,IDUMMY 1,IDUMMY,M,IDUMMY,CDUMMY,IDUMMY,CDUMMY,SOIVOL,A5DUMMY,DUMMY,DUMM 2Y,DUMMY,DUMMY,DUMMY,IDUMMY,IDUMMY,A2DUMMY,A2DUMMY,CROP) GO TO 32 END IF !RZ Also need to have L (see below) as a dummy variable used to hold number of cells !RZ contributing to TESnutrient so we get an accurate average later. ISOIL= SOIL(M)/256 !WB ISOIL = soil type of element M !RZ THIS RETURNS TYPE OF SOIL PSSA=(P0SOIL(M)+(P0ADD(M)/SOIVOL(ISOIL)))/SSAT(ISOIL) !WB ? = original P mass? / total specific surface area * * AMMONIUM AND ORGANIC N SEDIMENT BOUND ORIGINAL CONCENTRATION *A0SOIL IS EXPRESSED IN KG !RZ I think A0 and O0 soil are in kgnutrient/kg soil ANPSSA=(A0SOIL(M)+(A0ADD(M)/SOIVOL(ISOIL)))/SSAT(ISOIL) !WB = sed. bound ammonium soil conc. ? ONPSSA=(O0SOIL(M)+(O0ADD(M)/SOIVOL(ISOIL)))/SSAT(ISOIL) !WB = sed. bound org-N conc. ? !WB*******************do loop # 923************************** DO 33 IC=1,NPART !WB do from counter NC = 1 to # of particle size classes P0(M,IC)=SSA(ISOIL,IC)*PSSA/F(ISOIL,IC) !WB unknown; rwz looks like phosphorus per particle size class AN0(M,IC)=SSA(ISOIL,IC)*ANPSSA/F(ISOIL,IC) !WB unknown; rwz looks like nitrate per particle size class ON0(M,IC)=SSA(ISOIL,IC)*ONPSSA/F(ISOIL,IC) !WB unknown; rwz looks like organic nitrogen per particle size class ERP(IC)=0. !WB unknown; rwz not used in program; from faycal's dissertation, !RZ =P enrichment ratio STOLD(M,IC)=0. !WB SEDIMENT STORAGE AT PREVIOUS TIME STEP STNEW(IC)=0. !WB SEDIMENT STORAGE AT THIS TIME STEP ** NRZ 9/23/94 ** CORRECTION ** ADD ONPT AND ONI TO THESE INITIALIZATIONS ANPT(M,IC)=0. !WB unknown PPT(M,IC)=0. !WB unknown ONPT(M,IC)=0. !WB unknown !RZ see faycal's dissertation: sum of the initial values of the nutrient !RZ specie under consideration ANI(M,IC)=0. !WB unknown PI(M,IC)=0. !WB unknown ONI(M,IC)=0. !WB unknown !RZ seems from name like it might be inflowing value for each nutrient? ** NRZ 9/23/94 33 CONTINUE !WB***********************end do loop # 923*************** T12=0.0 T13(M)=0.0 KK=SOIL(M)/256 !WB soil type of current element = !RZ this is an integer, so if you look at soil(m), this gives the soil !RZ type because the remainder, rotation number, is truncated rbit0(m)=0. !WB unknown tpon(m)=0. !WB equiv. time to ponding, time to infiltrate cum. ponding under !WB ponded conditions timpon(m)=0. !WB time to ponding (min) testi(m)=0. !WB flag indicating ponding TESPLA=EDILAB(M)+TESPLA !WB ? = labile P in the EDI + ? !RZ this is just summing up the labile P in the EDI, for use later to get an average !RZ labile P in the EDI TESNH4=EDINH4(M)+TESNH4 !WB ? = NH4 in the EDI + ? !RZ this is just summing up the NH4 in the EDI, for use later to get an average !RZ NH4 in the EDI TESNO3=TESNO3+EDINO3(M) !WB ? = NO3 in the EDI + ? !RZ this is just summing up the NO3 in the EDI, for use later to get an average !RZ NO3 in the EDI !RZ URBAN:::L is incremented to record the number of cells actually contributing to !RZ the TES variables so an accurate average can be taken below. L=L+1 32 CONTINUE !WB**********************end do loop # 907*********************** !RZ URBAN:::changed the following variables to be divided by L instead !RZ of N IF (L.GT.0) THEN !RZ TESPLA=TESPLA/N TESPLA=TESPLA/L !WB ? = ? / # of overland flow elements !RZ average (over all cells in watershed) labile P in the EDI !RZ TESNO3=TESNO3/N TESNO3=TESNO3/L !WB ? = ? / # of overland flow elements !RZ average (over all cells in watershed) NO3 in the EDI !RZ TESNH4=TESNH4/N TESNH4=TESNH4/L !WB ? = ? / # of overland flow elements !RZ average (over all cells in watershed) NH4 in the EDI END IF C C C C **** START COMPUTATION FOR EACH HYDROGRAPH PRINT LINE AT DT*KPR. !WB ***DT = time incr, KPR = # of time increment routings b/t print lines C ***************************do loop 972*************************** DO 220 L=2,NDT !WB do from counter L = 2 to # of lines of hydrograph print LM1=L-1 !WB unknown T(L)=T(LM1) !WB real time at counter = time at L-1 C C **** CONTINUITY EQUATION FOR TIME INCREMENTS DT. C ***************************do loop 982*************************** DO 170 J=1,KPR !WB do from J = 1 to # of time increment routings b/t print lines C *** NRZ 9/15/94 C *** MODIFY ELEMENTS OF PI AND SI TO REPRESENT MULTIPLE OUTLETS *************************do loop #988**************************** DO 37 NCH=1,NCHAN+1 !WB do from NCH counter to # of channels + 1 SPT(NCH)=0. !WB accum sed. loss at previous time * * PSPT ACCUMULATED SEDIMENT-BOUND PHOSPHORUS LOSS PSPT(NCH)=0. DO 35 IC=1,NPART PSPT(NCH)=PSPT(NCH)+PI(CHOUT(NCH),IC) !WB ? = ? + inflow of P !RZ pspt=accumulated sediment-bound phosphorus 35 SPT(NCH)=SPT(NCH)+SI(CHOUT(NCH),IC) !WB accum sed loss previous time = same + sed. inflow 37 CONTINUE ***************************end do loop #988****************************** C *** NRZ 9/15/94 T(L)=T(L)+DTM !WB time = time + time increment in minutes C C **** CALCULATE NET RAINFALL FOR EACH GAGE AND SURFACE CONDITION AND C **** UPDATE INFILTRATION CAPACITIES WITHIN GAGE AREA ON TIME OR NET C **** RAINFALL CHANGE. C ***************************do loop 1014*************************** DO 90 JJ=1,NRG !WB do from counter JJ = 1 to # of rain gages IF (IIRRI.EQ.1) THEN IRRIGAT=2 CALL IRRIGATE(LDAY,RAITES,YERBEG,IDATE,IRRIGAT,ICR,T(L),TMAX, 1JJ,ITR,CU,N,CU1,DT) IF (SKIPFLAG.EQ.2) GO TO 230 IF (SKIPFLAG.EQ.1) GO TO 60 END IF ! if the irrigation flag is triggered, set the irrigat variable to 2 ! (this tells the subroutine to execute the second part of the ! subroutine); the subroutine returns skipflag. If skipflag is 2, ! that indicates that there is no more rainfall or irrigation; if ! skipflag is 1, it indicates that there is no more rainfall but ! irrigation is not completed yet. DO M=1,N IF (POND(M).GT.0) THEN IF (CALLBMP(M).EQ.1) THEN IF ((T(L).GE.TMAX).AND.(H2ODEPTH(POND(M)).GT.0.01).AND. 1 (T(L).LT.1440.)) THEN RATE(JJ)=0. QI(M)=0. GO TO 60 END IF IF (RAITES.NE.1) THEN RATE(JJ)=0. QI(M)=0. RC(JJ,ITR)=0. GO TO 60 END IF END IF END IF END DO !RZ If the depth of water in the BMP is greater than 0.01, then you need to continue !RZ to simulate the water loss until either the water is depleted or the next rainfall event !RZ occurs. NF(JJ)=NF(JJ)-1 !WB down counter from NFI = max # of time increments b/t infil. !WB recalc.'s ITR=JTR(JJ) !WB rainfall histogram counter = current rainfall intensity histogram !WB for rain gage i ITRM1=ITR-1 IF (T(L)-TC(JJ,ITR)) 60,60,40 !WB if time - jth time of rain gage i is < = > 0, !WB then go to 60, 60, 40, respectively 40 IF (T(L)-TMAX) 50,230,230 !WB if time - max time in hyetograph < = > 0, then go !WB to 50, 230, 230, respectively. C C **** NEW RAINFALL RATE, ALLOW FOR DTM BRIDGING TC VALUE. C 50 DI=T(L)-TC(JJ,ITR) !WB = sim time - rainfall histogram change time ITRP1=ITR+1 !WB RAINFALL HIST CNTER PLUS 1 = RAINFALL HIST CNTR + 1 RATE(JJ)=CU*(RC(JJ,ITRP1)*DI+RC(JJ,ITR)*(DTM-DI))/DTM !WB gage rainfall rate at gage i = conv mm/h to m^3/s * !WB (rainfall intensity * time increment + prev rainfall !WB intensity * (sim time increment - histogram change time)) !WB / sim time increment !RZ this determines the rainfall rate if the time increment is !RZ greater than the difference between the current time and the !RZ time increment from the weather file. i.e, it allows you to !RZ say that there was this much rain at this rate, then the rainfall !RZ rate changed and there's this much more; weight it by DI and DTM-DI !RZ and then divide by the total number of minutes to get in rainfall/min JTR(JJ)=JTR(JJ)+1 !WB current rainfall intensity histogram period for rain gage i = !WB same + 1 ITR=ITRP1 !WB rainfall histogram counter = SAME + 1 C C **** ADD WHOLE HISTOGRAM BLOCK TO TOTAL PRECIPITATION IN C **** PROPORTION TO WATERSHED AREA COVERED. C IF ((RAITES.NE.1).AND.(RC(JJ,ITR).GT.0.)) THEN CONTINUE END IF PREC=PREC+RC(JJ,ITR)*(TC(JJ,ITR)-TC(JJ,ITR-1))*FRA(JJ)/60. !WB accum depth of precip = same + rainfall intensity * !WB (time of jth histogram for period i - same, prev period) * !WB fraction of catchment area covered by i / 60 C C **** CALCULATE NET RAINFALL FOR EACH COVER. C ***********************do loop #1058************************************ 60 DO 70 I=1,ICR !WB do from counter I = 1 to # of cropping practices !RZ URBAN:::rate needs to have irrigation water added to it IF ((RAITES.NE.1).AND.(RATE2(I).GT.0.)) THEN CONTINUE END IF IF ((CROPNOIRR(I).EQ.0).AND.(IRRFLAG2(I).EQ.1)) THEN RATE2(I)=RATE(JJ)+IRRATE(I) ELSE RATE2(I)=RATE(JJ) END IF IF ((RAITES.NE.1).AND.(RATE2(I).GT.0.)) THEN RATE(JJ)=0. RATE2(I)=0. CONTINUE END IF !RZ commented lines below were used to test the irrigation subroutine ! IF (I.EQ.ICR) THEN ! IF (LDAY.NE.INTDAY) THEN ! WRITE (379,*) '--------------------------------------------------' ! DO ISH=1,ICR ! WRITE (379,1235) LDAY,YERBEG,ISH,RATE(JJ),RATE2(ISH),IRRATE(ISH) !1235 FORMAT (1X,I3,1X,I4,1X,I2,1X,F7.5,1X,F7.5,1X,F7.5) ! END DO ! INTDAY=LDAY ! END IF ! IF ((IRRFLAG2(I).EQ.1).AND.(I.EQ.ICR)) THEN ! IF (LDAY.NE.INTDAY) ! WRITE (377,*) '--------------------------------------------------' ! ! WRITE (377,1234) LDAY,YERBEG,1,RATE(JJ),RATE2(I),IRRATE(I), ! 1(1-PIV(1)*DT/TP1(1)),IRRTARGET(I),DURATION(I),IRRFLAG2(I) !1234 FORMAT (1X,I3,1X,I4,1X,I3,1X,F7.5,1X,F7.5,1X,F7.5,1X,F6.3,1X,F6.3, ! 1F8.2,1X,I1) ! ! INTDAY=LDAY ! END IF ! END IF R(JJ,I)=RAIN(RATE2(I),PIT(JJ,I),PER(I)) ! R(JJ,I)=RAIN(RATE(JJ),PIT(JJ,I),PER(I)) !WB Net rainfall rate, gage i, surface j = effective rainfall !WB rate (rate, interception storage, fraction of area covered !WB by foliage for surface type i) IF (R(JJ,I).EQ.SR(JJ).AND.NF(JJ).GT.0) GO TO 70 !WB if net rate = previous rate & down counter > 0 SR(JJ)=R(JJ,I) !WB prev rate = net rate NF(JJ)=-NFI !WB down counter = - max of time increments b/t infil recalc.'s 70 CONTINUE ************************end do loop #1058****************************** RATE(JJ)=RC(JJ,ITR)*CU !WB gage rate = intensity * conversion IF (NF(JJ).GT.0) GO TO 90 !WB if downcounter > 0, go to 90 C C **** CALCULATION OF INFILTRATION CAPACITY FOR EACH OVERLAND ELEMENT. C ***************************do loop #1080******************************** DO 80 M=1,N !WB do from overland flow element counter M = 1 to # of overland !WB flow elements IF (MOD(RANE(M),256).NE.JJ) GO TO 80 !WB (# of rain gage applicable to i - INT (same / 256) * 256) !WB NE raingage # counter K=MOD(SUR(M),256) !WB K=COVER type !WB INT(same/256)*256 KK=SOIL(M)/256 !WB soil type of i = soil type of i / 256 !RZ If the cell is urban, there is no potential infiltration; set equal !RZ to zero and skip over the function filt call. IF (URB(M).EQ.1) THEN FILTS(M)=0.0 DR(M)=0.0 GO TO 80 END IF FILTS(M)=FILT(PIV(M),FCAP1(KK),GWC(KK),DR(M),S(M),R(JJ,K) 1,CU2,ROUGH(K),HU(K),NEXP,ASMPER(M),KE(KK,K),PSIF(KK),PHIC(KK),T(L) 1,CU,LF(KK),KS(KK),K,kk,M,CUMIN1(M),rbit0(m),testi(m),timpon(m), & TPON(M),FILTS(M),DT,CU1,TP1(KK),A(KK)) !WB FILTS = infil cap of element M, PIV = vol of air filled pore !WB space, FCAP1 = field cap as fraction of pore space?, GWC = vol !WB of air filled pore space at field cap., DR = vert. drain loss, !WB S = storage at start of incr. i, R = net rainfall rate, CU2 = !WB conv, ROUGH = surf. storage depth param for i, HU = max ht diff !WB on soil surface, NEXP = ?, ASMPER = ?, KE = eff. hydr. !WB conductivity, PSIF = cap. pot. at infil. wetting front, PHIC = !WB corrected effective porosity, T = real time, CU = conversion, !WB LF = depth to wetting front, KS = sat hyd conductivity, !WB K = CROP TYPE (RZ), kk = soil type, M = element no., CUMIN1 = !WB cum. infiltration, rbit = ?, testi = ponding flag, !WB timpon = time to ponding, TPON = equil. time to ponding, FILTS = !WB infil cap, DT = sim time incr (sec), CU1 = conversion, TP1 = !WB porosity, A = ratio of sat. hydr. cond top layer & sat. hyd. !WB cond. for underlying soil 80 CONTINUE ************************end do loop #1080*************************** NF(JJ)=NFI !WB down counter = max # of time increments 90 CONTINUE ***************************end do loop 1014************************* C C **** CONTINUITY EQUATION EXPLICIT SOLUTION FOR EACH ELEMENT DURING C **** TIME INCREMENT, DT. C ***************************do loop # 1121*************************** DO 170 M=1,N2 !WB # of overland flow + channel elements SSTOR=S(M)+SS(M) !WB storage on element at end of time inc = storage at start + !WB incremental increase in storage IF (SSTOR.LT.0.) SSTOR=0. !WB avail. supply for infil. < 0 IF ((RAITES.NE.1).AND.(CALLBMP(M).EQ.1)) THEN IF ((SUB(POND(M)).EQ.0).AND.(H2ODEPTH(POND(M)).LT.0.01)) THEN GO TO 230 END IF END IF IF (POND(M).GT.0) THEN IF (CALLBMP(M).EQ.1) THEN IF (SUB(POND(M)).EQ.0) THEN IF (RANE(M).NE.0) THEN BMPLOC=2 CALL BMPS(BMPLOC,M,L,T,CU,CU1,CU2,DT,NEXP,FILTS,IDATE, 1 SIMDUR,LDAY,KPR,NDT,J,Q(M), 2 R(MOD(RANE(M),256),MOD(SUR(M),256)),IDUMMY,IDUMMY, 3 RAITES) ! IF (ENDNO3SI.GT.0.) ANO3SI(NDT,1)=ENDNO3SI GO TO 170 ELSE BMPLOC=2 CALL BMPS(BMPLOC,M,L,T,CU,CU1,CU2,DT,NEXP,FILTS,IDATE, 1 SIMDUR,LDAY,KPR,NDT,J,Q(M), 2 R(MOD(RANE(MYSHADOW(M)),256), 3 MOD(SUR(MYSHADOW(M)),256)),IDUMMY,IDUMMY, 4 RAITES) GO TO 170 END IF ELSE !RZ The following section routes flow from non-collecting bmp cells !RZ to the collecting bmp cells. As one will recall from the user's !RZ guide, a bmp that spans several cells is assigned one collecting !RZ cell (which holds the pond characteristics) and the rest of the !RZ cells are just told to route flow to that collecting cell (as !RZ done below). As in the rest of the program, the flow going to the !RZ receiving cell is calculated by adding the difference between the !RZ flow from last time and the flow from this time (this is necessary !RZ because of multiple contributing cells, you can't just zero QI before !RZ adding the new flow). D=QI(M)-Q(M) QI(NC(M))=D+QI(NC(M)) !WB inflow = inflow + depth increment SPI(NC(M))=SPI(NC(M))+SPI(M) !WB inflow of dissolved P = same + outflow AINH4(NC(M))=AINH4(NC(M))+AINH4(M) !WB inflow of dissolved NH4 = same + outflow of dissolved NH4 AINO3(NC(M))=AINO3(NC(M))+AINO3(M) !WB inflow of nitrate = same + outflow of NO3 DO IC=1,NPART !WB do from counter IC=1 to # of particles PI(NC(M),IC)=PI(NC(M),IC)+PI(M,IC) !WB inflow of sed. bound P = same + outflow PI(M,IC)=0. ANI(NC(M),IC)=ANI(NC(M),IC)+ANI(M,IC) !RZ inflow of sediment bound ammonia ANI(M,IC)=0. ONI(NC(M),IC)=ONI(NC(M),IC)+ONI(M,IC) !RZ inflow of sed. bound organic N ONI(M,IC)=0. SI(NC(M),IC)=SI(NC(M),IC)+SI(M,IC) !WB rate of sed. inflow = inflow + outflow SI(M,IC)=0. END DO Q(M)=QI(M) AINO3(M)=0. AINH4(M)=0. SPI(M)=0. GO TO 170 END IF END IF END IF !RZ flow will be routed differently if there is a bmp present; go to !RZ the end of catchment check before exiting to end of loop; because !RZ rfl is zero for channel cells, no modifications to bmps subroutine !RZ need to be made to specially accomodate channel cells. IF (M.GT.N) GO TO 100 !WB if element counter greater than # of overland flow elements C C **** OVERLAND ELEMENT. C I=MOD(RANE(M),256) !WB = # of rain gage applicable to i - INT(same/256) * 256 K=MOD(SUR(M),256) !WB = surface type on element i - INT(same/256) * 256 = cover type KK=SOIL(M)/256 !WB soil type of i = soil type of i / 256 !RZ all the above are divided by 256 because of the way the variable is !RZ set up. See the rane(i)=,sur(i)=,soil(i)= calculations for detail SUPP=.5*SSTOR+QI(M)+R(I,K) !WB avail. supply for infil = = 0.5*(end stor) + inflow + net rainfall !RZ sstor=2*(actual storage,S)/T (so must multiply by 0.5 to get s/t) FIL=FILTS(M) !WB infil = infil cap IF (FIL.GT.SUPP) FIL=SUPP !WB if infil > supply, then set them equal IF(FIL.LT.0) FIL=0.0 !WB if infil < 0, then set infil = 0 if (dr(m).lt.0.) dr(m)=0. !WB if vert. drain<0, then set = 0 CUMIN1(M)=CUMIN1(M)+(FIL/CU)*(DT/3600.) !WB cum infil = same + (infil/conv) * (time inc / 3600(sec / hr)) CNO3(M)=CNO3(M)+(DR(M)/CU)*(DT/3600) !WB accum perc during infil = same + (vert drain / conv) * !WB ( time inc / 3600) PIV(M)=PIV(M)+DR(M)-FIL !WB vol airspace = same + vert drain - infil IF ((IRRCYCLE(K).EQ.1).AND.(FREQ(K).EQ.3).AND.(CROPNOIRR(K).EQ.0)) 1THEN !RZ if the crop is in its irrigation cycle and has frequency type 3 and !RZ is still irrigating today IF ((1.-PIV(M)*DT/TP1(KK)).LT.IRRTARGET(K)) THEN !RZ if the soil moisture (decimal percent) is less than the target value then DURATION(K)=1440. !set equal to the total number of minutes in a day; don't !want irrigation to last more than one day though. ELSE DURATION(K)=0. !set low enough that it will definitely be less than T(L) so !irrigation will no longer be performed for this crop today CROPNOIRR(K)=1 !crop no longer irrigates today END IF END IF SDR=SDR+DR(M) !WB accum ground H2O storage = accum groun H2O storage + vert drain IF ((RAITES.NE.1).AND.(R(I,K).GT.0.)) THEN CONTINUE END IF FLIN=QI(M)+R(I,K)-FIL !WB net rate of flow into an element less losses = inflow + net !WB rainfall - infil GO TO 110 C C **** CHANNEL ELEMENT. C 100 K=21 !RZ URBAN:::If it is an urban cell, then the FLIN will not include channel drainage IF (URB(M).EQ.1) THEN FLIN=QI(M)+DIN(M) GO TO 110 END IF FLIN=QI(M)+CHDR+DIN(M) !WB net rate of flow into an element less losses = inflow + ground !WB water discharge + accum tile drainage rate C C **** COMBINE INITIAL INFLOW, OUTFLOW AND STORAGE WITH ACCUMULATED C **** INFLOW. C 110 FHS=FLINS(M)+FLIN !WB FHS = (storage, inflow + outflow) + net rate of flow into a !WB channel element (less losses) IF (SSTOR.GT.DIR(K)) GO TO 130 !WB storage on element at end of time increment > ret. depth C C **** NO RUNOFF FROM ELEMENT. C 120 S(M)=FHS !WB storage = combined water SS(M)=0. !WB incremental increase in storage = 0 FLINS(M)=FLIN+FHS !WB storage, inflow, and outflow = net inflow rate + total from above !RZ fill this back in if needed URBAN::: if the depth of water in the pond is greater than 0.01 for a !RZ dry pond or infiltration trench (.gt. orbot for wet ponds), simulate !RZ water loss in the pond for today even if flow on element is .lt. 0. !RZ the wet pond stipulation was added because a wet pond should remain full !RZ between storms, so this way the water !RZ in the pond is not totally depleted between storms. IF (Q(M).EQ.0.) GO TO 170 !WB if outflow > 0 129 D=-Q(M) !WB depth increment in seg. curve = - outflow Q(M)=0. !WB outflow = 0 GO TO 150 C C **** DIRECT SOLUTION OF CONTINUITY EQUATION BY LINEARIZATION. C 130 Y=SC*(SSTOR-DIR(K)) !WB seg. number on depth value = depth inc. on seg. !WB curve*(storage at end of time increment - ret. depth) IY=Y+1. !MYQ=Y+1. !WB seg # on discharge curve IF (IY.LT.300) GO TO 140 !WB this and next 2 lines are the formulation of an error (exceed array bounds) WRITE (2,330) M WRITE (2,*) 'FLOWDEPTH=', Y/SC IY=299 STOP 140 Y=IY-1 !WB Y = incremented IY -1 !RZ = truncated original Y (originally Y was real, this makes it an integer). IF (M.GT.N) THEN CHWID=CWID(M)+WIDINC(M) !WB THE CHANNEL WIDTH IS EQUAL TO ORIGINAL WIDTH + ANY WIDTH INCREASE THAT OCCURS !WB DURING SIMULATION. SEE SUBROUTINE SED FOR INFO ON THIS VARIABLE !WB THE CHWID VAR IS USED ONLY HERE AND THEREFORE ISN'T INCLUDED IN !WB THE COMMON BLOCKS. B(M)=CONSTHLD(M)/MNCHNTOT(M)/XHOLD(M)*(DX/CHWID/XHOLD(M)) 1**0.6667*DSQRT(SL(M)) !WB ADJUST CHANNEL CONVEYANCE TO ACCOMODATE CHANNEL WIDENING ENDIF MYQA=(SSTOR-DIR(K))**(5./3.) !RZ IF (QA(IY)>0) THEN !RZ WRITE (*,*) MYQA !RZ WRITE (*,*) MYQ,IY,QA(IY) !RZ END IF QL=B(M)*MYQA !WB discharge at lower end of seg IY on discharge curve = !WB conveyance in Manning's eqn * incr. depth power value QD=B(M)*(QA(IY+1)-QA(IY)) !RZ QD=B(M)*(((SSTOR-DIR(K))+1./SC)**(5./3.)-MYQA) QA (IY) AND (IY+1) RESULT FILE !WB differential = conveyance (difference) SSTOR=(FHS-QL+QD*(Y+DIR(K)*SC))/(1.+QD*SC) !RZ SSTOROLD=SSTOR !RZ SSTOR=(FHS-MYQA+B(M)*SSTOR)/(1+B(M)) !WB storage = (combined water - curve lower discharge + !WB discharge differential*(seg. # + ret. depth for crop practice i !WB * depth incr) / (1+discharge differential*depth incr) !RZ SSTOR=FHS-QL IF (SSTOR.LE.DIR(K)) GO TO 120 !WB if storage at end of time increment < ret. depth Q2=QL+QD*((SSTOR-DIR(K))*SC-Y) !RZ Q2=QL+B(M)*(SSTOR-SSTOROLD) !WB outflow at end of time increment = discharge at lower end + !WB differential ((storage - ret) * depth incr. - seg. depth) !RZ Q2=QL D=Q2-Q(M) !WB depth increment in seg. depth curve = outflow from at end of !WB time increment - outflow in segment !RZ This is NOT the depth increment in seg. depth curve - just one of the !RZ many instances in this program where one variable name is used to !RZ represent completely different variables. This appears to be !RZ the outflow from the element minus the inflow on the element, or !RZ perhaps the water on the element...something like that. Q(M)=Q2 !WB set em equal SS(M)=SSTOR-S(M) !WB increase in storage = storage - storage at start S(M)=SSTOR !WB reset storage at beginning equal to storage at end of increment FLINS(M)=FLIN+SSTOR-Q2 !WB storage, inflow + outflow = net inflow less losses + storage - !WB outflow at end of time incre !RZ THE FOLLOWING ARE STATEMENTS TO PRINT OUT EACH OF THE PERTINENT VARIABLES ABOVE, !RZ IN AN ATTEMPT TO ISOLATE THE CAUSE OF AN ERROR WHEN QA IS DIRECTLY CALCULATED. !RZ WRITE (377,337) M,B(M),QA(IY),MYQA,SSTOR,Q2,Q(M),SS(M),S(M), !RZ & FLINS(M),QD !RZ 337 FORMAT (1X,I5,F8.2,F8.3,F8.3,F8.2,F8.4,F8.4,F8.2,F8.2,F8.2,F8.2) C C.....SEDIMENT CALCULATION..... C 150 IF (M.LE.N) GO TO 156 !WB if element # less than # of overland flow elements, JUMP DOWN TO !WB DO O.F. CALCULATIONS C C......COMPUTE TRANSPORT/DEPOSITION FOR CHANNEL FLOW C KK=SOIL(M)/256 CALL SED(CWID(M),0.,DT,0.,M,N,KK,DX,N2) !WB calculate sediment movement in channel, JUMP DOWN TO THE NEXT !WB CALL SED STATMENT FOR DEFINITIONS OF WHAT'S BEING PASSED. CALL PBOUND(NPART,M) !RZ URBAN:::THE SOLUBLE NUTRIENTS SUBROUTINES CALCULATE PARTITIONING OF !RZ NUTRIENTS FROM SEDIMENT, NOT REALLY APPLICABLE FOR IMPERVIOUS AREAS. IF(URB(M).EQ.1) THEN CALL AMMON(NPART,M) CALL ORGN(NPART,M) URBAN=7 IDUMMY=0 DUMMY=0. CALL URBANIZED(URBAN,IDUMMY,IDUMMY,A1DUMMY,IDUMMY,IDUMMY,IDUMM 1Y,IDUMMY,M,IDUMMY,CDUMMY,IDUMMY,CDUMMY,A3DUMMY,A5DUMMY,DUMMY,DUMMY 2,DUMMY,DUMMY,DUMMY,IDUMMY,IDUMMY,A2DUMMY,A2DUMMY,CROP) ELSE CALL SOLUBP(DX2,KK,M,I,K,DT,T12,L,T11,SSTOR,FIL,SE,N & ,CUMIN1,CU,NPART) CALL AMMON(NPART,M) CALL WATNH(SSTOR,FIL,M,DT,N,CUMIN1,CU,KK,NPART) CALL NO3Z(SSTOR,FIL,M,DT,N,CUMIN1,CU) CALL ORGN(NPART,M) END IF DO 151 IC=1,NPART !WB do from this counter to the # of particles SI(M,IC)=0.0 !WB set sediment inflow back to 0 151 CONTINUE IF (M.EQ.7822) THEN CONTINUE END IF C C......REMEMBER ALL CHANNEL FLOW MOVES WITH ITS "COLUMN" DESIGNATOR C K=NC(M) !WB set K = # of element receiving outflow from element i in a !WB column direction QI(K)=QI(K)+D !WB inflow = inflow + depth increment SPI(K)=SPI(K)+SP2(M) !WB inflow of dissolved P = same + outflow AINH4(K)=AINH4(K)+OUTNH4(M) !WB inflow of dissolved NH4 = same + outflow of dissolved NH4 AINO3(K)=AINO3(K)+OUTNO3(M) !WB inflow of nitrate = same + outflow of NO3 *******************************do loop #1276*********************** DO 152 IC=1,NPART !WB do from counter IC=1 to # of particles PI(K,IC)=PI(K,IC)+PE(IC) !WB inflow of sed. bound P = same + outflow ANI(K,IC)=ANI(K,IC)+ANE(IC) !WB ? !RZ inflow of sediment bound ammonia ONI(K,IC)=ONI(K,IC)+ONE(IC) !WB ? !RZ inflow of sed. bound organic N SI(K,IC)=SI(K,IC)+SE(IC) !WB rate of sed. inflow = inflow + outflow 152 CONTINUE 153 CONTINUE *******************************end do loop #1276******************* IF(M.NE.N2) GO TO 170 !WB if element counter # does not equal total # of elements + channels *******************************do loop #1293************************** DO 154 IC=1,NPART !WB do from counter IC=1 to # of particles ER(IC)=ER(IC)+SE(IC) !WB amt of particle size i leaving watershed = same + movement from !WB element 154 CONTINUE *******************************end do loop #1293********************** GO TO 170 C C.....COMPUTE TRANSPORT/DEPOSITION FOR OVERLAND FLOW C 156 CONTINUE CALL WETDEP(RATE(K),M,LDAY,MOD(SUR(M),256)) !RZ call the wet deposition subroutine; determines the amount of wet deposition !RZ for this rainfall time increment CALL SED(DX,R(I,K),DT,DIR(K),M,N,KK,DX,N2) !WB DX = cell width, R = net rainfall, DT=TIME INCREMENT, !WB DIR= ret. depth, M = element counter, N = # of overland flow !WB elements, KK = soil type for current element, DX = cell width !WB N2=# OF O.F. + CHANNEL CELLS CALL PBOUND(NPART,M) !RZ URBAN:::THE SOLUBLE NUTRIENTS SUBROUTINES CALCULATE PARTITIONING OF !RZ NUTRIENTS FROM SEDIMENT, NOT REALLY APPLICABLE FOR IMPERVIOUS AREAS. IF(URB(M).EQ.1) THEN CALL AMMON(NPART,M) CALL ORGN(NPART,M) URBAN=7 DUMMY=0. IDUMMY=0 CALL URBANIZED(URBAN,IDUMMY,IDUMMY,A1DUMMY,IDUMMY,IDUMMY,IDUMM 1Y,IDUMMY,M,IDUMMY,CDUMMY,IDUMMY,CDUMMY,A3DUMMY,A5DUMMY,DUMMY,DUMMY 2,DUMMY,DUMMY,DUMMY,IDUMMY,IDUMMY,A2DUMMY,A2DUMMY,CROP) ELSE CALL SOLUBP(DX2,KK,M,I,K,DT,T12,L,T11,SSTOR,FIL,SE,N & ,CUMIN1,CU,NPART) CALL AMMON(NPART,M) CALL WATNH(SSTOR,FIL,M,DT,N,CUMIN1,CU,KK,NPART) CALL NO3Z(SSTOR,FIL,M,DT,N,CUMIN1,CU) CALL ORGN(NPART,M) END IF *******************************do loop #1319************************** DO 157 IC=1,NPART !WB do from counter IC = 1 to # of particles SI(M,IC)=0. !WB sediment inflow = 0 157 CONTINUE ******************************* end do loop #1319********************* C C......PROPORTION OUTFLOW AND SEDIMENT TO DOWNSLOPE ADJACENT ROW C............AND COLUMN ELEMENTS..... C IF(M.LT.N2) GO TO 160 !WB if el # < # overland flow + channel elements *******************************do loop #1332************************** DO 158 IC=1,NPART !WB do from counter IC =1 to # of particles ER(IC)=ER(IC)+SE(IC) !WB amt of part. type i leaving watershed = same + sed. exiting !WB the element 158 CONTINUE ****************************end do loop #1332************************* 160 CONTINUE ! URBAN:: FLOW IS ROUTED DIFFERENTLY FOR URBAN BMPS ! IF (POND(M).GT.0) THEN ! IF (CALLBMP(M).EQ.1) THEN ! IF (SUB(POND(M)).EQ.0) THEN ! BMPLOC=2 ! CONTINUE ! CALL BMPS(BMPLOC,M,L,T,CU,CU1,CU2,DT,NEXP,FILTS,IDATE,SIMDUR ! 1 ,LDAY,KPR,NDT,J,D) ! GO TO 170 ! END IF ! END IF ! END IF DRA=D*RFL(M) !WB incremental increase in outflow = depth increment * fraction !WB of discharge in row dir I=NR(M) !WB # of element receiving outflow from element I in row dir. K=NC(M) !WB # of element receiving outflow from element I in col. dir. QI(I)=QI(I)+DRA !WB inflow to row element i = same + incremental increase in outflow QI(K)=QI(K)+D-DRA !WB inflow to column element i = same + depth increment - increase !WB in outflow, row direction PSIRA=SP2(M)*RFL(M) !WB = outflow of dissol. P * fraction of discharge from element !WB flowing in row direction SPI(I)=SPI(I)+PSIRA !WB inflow of dissolved P from adjacent cells (row dir) = same + !WB above SPI(K)=SPI(K)+SP2(M)-PSIRA !WB inflow of dissol P (column dir) = same + outflow dissolv P - !WB fraction in row dir AINH4(I)=AINH4(I)+OUTNH4(M)*RFL(M) !WB inflow dissol NH4 (row dir) = same + outflow from M * fraction !WB of discharge AINH4(K)=AINH4(K)+OUTNH4(M)-OUTNH4(M)*RFL(M) !WB inflow diss NH4 (col dir) = same + outflow col dir - !WB outflow col dir * fraction AINO3(I)=AINO3(I)+OUTNO3(M)*RFL(M) !WB inflow dissol NO3 (row dir) = same + outflow * rel fraction AINO3(K)=AINO3(K)+OUTNO3(M)-OUTNO3(M)*RFL(M) !WB inflow dissol NO3 (col dir) = same + outflow - outflow * rel fract *******************************do loop #1380************************** DO 162 IC=1,NPART !WB do this loop from counter IC=1 to # of particle size classes C *** NRZ C *** CHANNEL CORRECTION PRA=PE(IC)*RFL(M) !WB = outflow of sed. bound P * fraction of discharge from el !WB flowing in row dir ANRA=ANE(IC)*RFL(M) !WB = outflow of sed. bound NH4 for particle class i * fraction !WB of discharge ONRA=ONE(IC)*RFL(M) !WB = outflow of sed. bound org. N * fractional flow discharge !WB in row dir SRA=SE(IC)*RFL(M) !WB portion of sed. leaving and flowing in row dir = sed. exiting * !WB fraction of flow in row dir PI(I,IC)=PI(I,IC)+PRA !WB = inflow of sed bound P (row, part. size class) + above PI(K,IC)=PI(K,IC)+PE(IC)-PRA !WB = inflow of sed bound P (col, part. size class) + above ANI(I,IC)=ANI(I,IC)+ANRA !WB see above ANI(K,IC)=ANI(K,IC)+ANE(IC)-ANRA !WB see above ONI(I,IC)=ONI(I,IC)+ONRA !WB see above ONI(K,IC)=ONI(K,IC)+ONE(IC)-ONRA !WB see above SI(I,IC)=SI(I,IC)+SRA !WB see above SI(K,IC)=SI(K,IC)+SE(IC)-SRA !WB see above 162 CONTINUE ***************************end do loop #1380************************** C *** NRZ END 170 CONTINUE ***************************end do loop 982*************************** ***************************end do loop 1121************************** IF (CHN.LT.1..OR.SDR.EQ.0.) GO TO 180 !WB if # of channel seg's < 1 or accum groundH2O storage = 0 C C **** CALCULATE TILE DRAINAGE AND GROUNDWATER CONTRIBUTION. C XPR=KPR !WB = # of time increment routings b/t print lines CALL DRAIN (DR,DC,DIN,N,N1,N2,STD,TIAL,RFL,NR,NC) !WB DR = vert. drain loss, DC = tile drain. coeff, DIN = accum !WB tile drain, N = # overland flow el's, N1 = N + 1, N2 = # overland !WB flow + # channel el's, STD = total inflow to tile lines, TIAL = !WB flag, RFL = fraction of discharge in row dir, NR = # el receiving !WB flow in row dir, NC = # el receiving flow in col dir SDR=SDR-STD*XPR !WB groundwater storage = same - total inflow * # time increment !WB routings CHDR=SDR*GRF/XPR/CHN !WB groundH2O discharge into element = groundwater storage * !WB fractional rate of baseflow release / XPR / # of channel segments SDR=SDR*(1.-GRF) !WB groundwater storage = same * (1 - release fraction) C C **** OUTPUT PRINT SECTION. C **** NRZ 9/14/94 C **** ADD EXTRA DIMENSION TO KEEP TRACK OF EACH CHANNEL OUTLET C 180 Q1(L)=QI(NN)/CONV ****************************do loop #1453************************** 180 DO 219 NCH=1,NCHAN+1 !WB do from channel counter NCH = 1 to # of channels + 1 Q1(L,NCH)=QI(CHOUT(NCH))/CONV !WB discharge from catchment at ith hydrograph line = inflow !WB to el i / catchment conversion SIG(NCH)=0. !WB sum of sediment inflow values for all particle size clases C *** NRZ C *** CHANNEL ADDITION C *** ACCUMULATE KG OF SEDIMENT FOR EACH PARTICLE CLASS ****************************do loop #1465************************** DO 185 IC=1,NPART !WB do from counter IC=1 to # of particle size classes SEDG(NCH,IC)=0. !WB sed of particle class i draining from a channel for a !WB given print line SIG(NCH)=SIG(NCH)+SI(CHOUT(NCH),IC) !WB sum of sediment for all particle size classes = same + !WB sed inflow (channel outlet cell, particle size class) SEDG(NCH,IC)=SEDG(NCH,IC)+SI(CHOUT(NCH),IC) !WB sed drainage = same + sed. inflow (channel outlet cell, !WB part size class) 185 CONTINUE ************************end do loop #1465************************** ****************************do loop #1479************************** DO 187 IC=1,NPART !WB do from counter IC=1 to # of particle size classes SEDH(NCH,L,IC)=SEDG(NCH,IC)*DT !WB sed from catchment of particle class i at hydrograph line !WB L = channel out * time increment 187 CONTINUE ************************end do loop #1479************************** C *** NRZ END SSI(L,NCH)=SIG(NCH)*DT !WB accum sed out of catchment for a given storm = sum of all sed !WB size classes * time increment QHYP(L,NCH)=QI(CHOUT(NCH))*DT !WB FLOW RATE USED IN HYDROGRAPH PLOTTING OF NUTRIENT VARIABLES QI (M3/S) * DT (S)=M3 IF (QI(CHOUT(NCH)).GT.0.) GO TO 190 !WB if discharge from catchment > 0 , then SSCON(L,NCH)=0. !WB sed conc at print line L of hydrograph for outlet i = 0 GO TO 200 190 SSCON(L,NCH)=(SIG(NCH)-SPT(NCH))/(SIG(NCH)-SPT(NCH)+ & QI(CHOUT(NCH))*CE6)*1000000. !WB sed. conc at print line L of hydrograph for outlet i = !WB (sed accum - sed accum prev time step + Qinflow)*CE6)*1000000 200 IF (Q1(L,NCH).GT.QMAX) QMAX=Q1(L,NCH) !WB if flow out of catchment > qmax, qmax = outflow IF (SSCON(L,NCH).GT.CMAX) CMAX=SSCON(L,NCH) !WB if sed conc > ?max VOL(NCH)=VOL(NCH)+Q1(L,NCH) !WB runoff depth for outlet i = same + flow out RW(L,NCH)=0. !WB average rainfall intensity = 0 ****************************do loop #1509************************** DO 210 I=1,NRG !WB do from counter I = 1 to # of rain gages J=JTR(I) !WB current rainfall intensity histogram period for rain gage 210 RW(L,NCH)=RW(L,NCH)+RC(I,J)*FRA(I) !WB ave rainfall intensity = same + rainfall intensity for !WB gage i * fraction of catchment covered by gage ************************end do loop #1509************************** IF (RW(L,NCH).GT.RMAX) RMAX=RW(L,NCH) !WB if ave intensity > rmax, rmax = ave intensity * *DETERMINE PHOSPHORUS OUTPUT * PSIG(NCH)=0. !WB accum sed bound P loss for all particle size classes draining !WB to outlet i = 0 ** NRZ (8/31/94) ** ACCUMULATE KG OF SEDIMENT BOUND P FOR EACH PARTICLE CLASS ****************************do loop #1531************************** DO 215 IC=1,NPART !WB do from counter IC = 1 to # of particle size classes PSEDG(NCH,IC)=0. !WB sed bound P from channel = 0 PSIG(NCH)=PSIG(NCH)+PI(CHOUT(NCH),IC) !WB sum of sed bound P to outlet = same + inflow of sed. bound !WB P from adj cells PSEDG(NCH,IC)=PSEDG(NCH,IC)+PI(CHOUT(NCH),IC) !WB sed bound P from channel = same + inflow from channel out 215 CONTINUE ************************end do loop #1531************************** ****************************do loop #1543************************** DO 216 IC=1,NPART !WB do from counter IC = 1 to # of particle size classes PSEDH(NCH,L,IC)=PSEDG(NCH,IC)*DT*1000. !WB sed bound P leaving catchment = sed bound P leaving channel * !WB time incr * 1000 216 CONTINUE ************************end do loop #1543************************** ** NRZ (8/31/94) PSSI(L,NCH)=PSIG(NCH)*DT*1.E+3 !WB sum of sed. bound P loss from catchment = sum of sed bound P !WB draining to outlet * time inc * 1000 SPSSI(L,NCH)=SPI(CHOUT(NCH))*DT*1000. !WB sum of dissol P loss from catchment to outlet i = inflow of !WB dissol P * time inc * 1000 * *DETERMINE NITROGEN OUTPUT * ANSIG(NCH)=0. !WB sum of sed bound NH4 loss to outlet i for all part size classes ONSIG(NCH)=0. !WB sum of sed bound TKN loss to outlet i for all part size classes ** NRZ (8/31/94) ** ACCUMULATE KG OF SEDIMENT BOUND NH4 AND TKN FOR EACH PARTICLE ** CLASS ****************************do loop #1572************************** DO 217 IC=1,NPART !WB do from counter IC = 1 to # of particle size classes ANSEDG(NCH,IC)=0. !WB Sediment bound NH4 for particle class i draining from channel !WB for a given hydrograph print line (kg/sec) = 0 ONSEDG(NCH,IC)=0. !WB Sediment bound TKN for particle class i draining from channel !WB for a given hydrograph print line (kg/sec) = 0 ANSIG(NCH)=ANSIG(NCH)+ANI(CHOUT(NCH),IC) !WB sum of sed bound NH4 loss to outlet i for all part size !WB classes = same + ? ANSEDG(NCH,IC)=ANSEDG(NCH,IC)+ANI(CHOUT(NCH),IC) !WB Sediment bound NH4 for particle class i draining from channel !WB for a given hydrograph print line (kg/sec) = same + ? ONSIG(NCH)=ONSIG(NCH)+ONI(CHOUT(NCH),IC) !WB sum of sed bound TKN loss to outlet i for all particle size !WB classes = same + ? ONSEDG(NCH,IC)=ONSEDG(NCH,IC)+ONI(CHOUT(NCH),IC) !WB Sediment bound TKN for particle class i draining from channel !WB for a given hydrograph print line (kg/sec) = same + ? 217 CONTINUE ************************end do loop #1572************************** ****************************do loop #1596************************** DO 218 IC=1,NPART !WB do from counter IC = 1 to # of particle size classes ANSEDH(NCH,L,IC)=ANSEDG(NCH,IC)*DT*1000. !WB Sediment bound NH4 for particle class i and hydrograph line L !WB leaving catchment (kg) = Sediment bound NH4 for particle !WB class i draining from channel for a given hydrograph print !WB line (kg/sec) * time increment * 1000 ONSEDH(NCH,L,IC)=ONSEDG(NCH,IC)*DT*1000. !WB Sediment bound TKN for particle class i and hydrograph line L !WB leaving catchment (kg) = Sediment bound NH4 for particle class !WB i draining from channel for a given hydrograph print line !WB (kg/sec) * time incr * 1000 218 CONTINUE ************************end do loop #1596************************** ** NRZ (8/31/94) ANSSI(L,NCH)=ANSIG(NCH)*DT*1.E+3 !WB Accumulated sediment-bound ammonium loss from catchment draining !WB to outlet i at hydrograph line L for a given storm(g) = !WB Accumulated sediment-bound ammonium loss for all particle size !WB classes draining to outlet i for a given hydrograph print !WB line (kg/sec) * time increment * 1000 ONSSI(L,NCH)=ONSIG(NCH)*DT*1.E+3 !WB Accumulated sediment-bound TKN loss from catchment draining to !WB outlet i at hydrograph line L for a given storm (g) = !WB Accumulated sediment-bound TKN loss for all particle size classes !WB draining to outlet i for a given hydrograph print line (kg/sec) * !WB time incr * 1000 C CONVERTING NITROGEN OUTPUT FROM KG TO G ANH4SI(L,NCH)=AINH4(CHOUT(NCH))*1000.*DT !WB Accumulated dissolved ammonium loss from catchment draining to !WB outlet i at hydrograph line L for a given storm (g) = !WB Inflow of dissolved ammonium from adjacent cells (kg/s) * 1000 * !WB time increment ANO3SI(L,NCH)=AINO3(CHOUT(NCH))*1000.*DT !WB Accumulated dissolved nitrate loss from catchment draining to !WB outlet i at hydrograph line L for a given storm (g) = !WB Inflow of dissolved NO3 from adjacent cells (kg/s) * 1000 * time !WB increment 219 CONTINUE ************************end do loop #1453************************** C **** NRZ 9/14/94 C C **** PRINT ONE HYDROGRAPH LINE..... C 220 CONTINUE *******************************end do loop #972******************** 222 FORMAT(1X,F7.1,5(1X,F12.4)) !WB this is used nowhere. try to find 222 C C **** END OF HYDROGRAPH. PRINT TOTAL RUNOFF AND RAINFALL. C L=NDT+1 !WB Number of last element in row and a counter = Number of lines of !WB hydrograph print + 1 TOTANO3SI=0. DO NCH=1,NDT TOTANO3SI=TOTANO3SI+ANO3SI(NCH,1) END DO !WB*************************do loop # 1684******************** 230 DO 228 NCH=1,NCHAN+1 !WB do from channel counter = 1 to # of channels + 1 C **** NRZ 9/10/94 C **** ACCUMULATE RAINFALL AMOUNT IF (NCH.EQ.1) TPREC=TPREC+PREC !WB if channel counter = 1, then Accumulated rainfall for !WB simulation (mm) = same + Accumulated depth of precipitation (mm) C **** NRZ END VOL(NCH)=(VOL(NCH)-.5*Q1(L-1,NCH))*DT*DBLE(KPR)/3600. !WB Runoff depth for outlet i for a given storm (mm) = same - 0.5 * !WB Flow out of catchment draining to outlet i at hydrograph line !WB L (mm/h) * time increment * Number of time increment routings !WB between print lines / 3600 C *** THE NUMBER OF CELLS DRAINING INTO EACH CHANNEL NETWORK IS COMPUTED FROM C *** ARC-INFO, AND THIS IS CONVERTED TO AREA BY MULTIPLYING THE NUMBER OF C *** CELLS BY THE AREA OF EACH CELL IN HA. IF THIS IS THE SEDIMENT COMING C *** FROM THE "LEAKY CELLS", THE AREA IS COMPUTED BY MULTIPLYING THE C *** PERCENTAGE OF CELL AREA LEAKING BY THE AREA OF EACH CELL. C X=SSI(L-1)/AREA IF (NCH.LE.NCHAN) THEN !WB if channel counter is less than number of channels XS(NCH)=SSI(L-1,NCH)/(DBLE(NCELLS(NCH))*AREA2) !WB Accumulated sediment loss out of catchment for outlet i for !WB a given storm (kg/ha) = Accumulated sediment loss out of !WB catchment at print line L of hydrograph for outlet i for a !WB given storm (kg) / (Number of cells in channel network i !WB (entered in input file) * Element or channel area (m2)) ELSE C *** NRZ 7/29/95 C *** ADDED "IF OUTSID.GT.0" IN ORDER TO ELIMINATE 0/0 WHEN NO CELLS LEAK IF (OUTSID.GT.0) XS(NCH)=SSI(L-1,NCH)/(OUTSID*AREA2) !WB IF Area of watershed border elements which drain outside of !WB watershed > 0, then Accumulated sediment loss out of catchment !WB for outlet i for a given storm (kg/ha) = Accumulated sediment loss !WB out of catchment at print line L of hydrograph for outlet i for a !WB given storm (kg) / (Area of watershed border elements which drain !WB outside of watershed * Element or channel area (m2)) ENDIF CONFAC=AREA*10000. !WB = Catchment area as sum of element areas, ha * 10000 CONFA1=CONFAC/1000. !WB = Catchment area as sum of element areas, ha * 10000 / 1000 VOL1F(NCH)=VOL1F(NCH)+VOL(NCH) !WB Accumulated runoff depth for outlet i for the simulation (mm) = !WB same + Runoff depth for outlet i for a given storm (mm) VOL1X(NCH)=VOL1X(NCH)+XS(NCH) !WB Accumulated sediment loss out of catchment for outlet i for !WB the simulation (kg/ha) = same + XS (NCH) from above NUNIT=NCH+10 !WB = channel counter + 10 IF(YEAR0.NE.YERBEG) THEN !WB if year0? does not equal the beginning year of the simulation !RZ if previous year is not current year (i.e., you just changed !RZ years in the simulation and you need to write an output file) DO 9902 NZ=0,NCHAN !WB do from counter NZ = 0 to # of channels 9902 WRITE(NUNIT+NZ,*) YERBEG !WB write to the channel file #(nunit+nz) the beg. year of sim !RZ YERBEG is actually the current year. This increments the !RZ year in the channel output file so you can see what's going on. YEAR0=YERBEG !WB reset the year0 var to the beginning year of the simulation !RZ reset the year0 var to the current year ENDIF !WB put your finger on the side of your head and scratch, scratch !WB and say "hmmmmmmm". I have no idea what the previous lines !WB are used for 10/15/98 RNO3(NCH)=RNO3(NCH)+ANO3SI(L-1,NCH) !WB Accumulated dissolved nitrate loss from catchment draining to !WB outlet i for the simulation (g) = same + Accumulated dissolved !WB nitrate loss from catchment draining to outlet i at hydrograph !WB line L for a given storm (g) RNH4S(NCH)=RNH4S(NCH)+ANH4SI(L-1,NCH) !WB Accumulated dissolved NH4 loss from catchment draining to outlet !WB i for the simulation (g)= same + Accumulated dissolved ammonium !WB loss from catchment draining to outlet i at hydrograph line L !WB for a given storm (g) RNH4SE(NCH)=RNH4SE(NCH)+ANSSI(L-1,NCH) !WB Accumulated sediment-bound ammonium loss from catchment draining !WB to outlet i for the simulation (g) = same + Accumulated !WB sediment-bound ammonium loss from catchment draining to outlet i !WB at hydrograph line L for a given storm(g) RPHOS(NCH)=RPHOS(NCH)+SPSSI(L-1,NCH) !WB Accumulated dissolved P loss from catchment draining to outlet i !WB for the simulation (g) = same + Accumulated dissolved P loss from !WB catchment draining to outlet i at hydrograph print line L for a !WB given storm (g) RORGN(NCH)=RORGN(NCH)+ONSSI(L-1,NCH) !WB Accumulated sediment-bound TKN loss from catchment draining to !WB outlet i for the simulation (g) = same + Accumulated sediment-bound !WB TKN loss from catchment draining to outlet i at hydrograph line L !WB for a given storm (g) RSEDP(NCH)=RSEDP(NCH)+PSSI(L-1,NCH) !WB Accumulated sediment-bound P loss from catchment draining to outlet !WB i for the simulation (g) = same + Accumulated sediment-bound P loss !WB from catchment draining to outlet i at hydrograph line L for a given !WB storm (g) IF (NCH.LT.NCHAN+1) THEN IF (NSBS.EQ.1)THEN DO JKK=1,20 CNT2=0 do CNT=1,NN-1 JK=MOD(SUR(CNT),256) KKX=(SOIL(CNT)/256) if (jk.eq.jkk) then IF (CNT2.EQ.1) GOTO 3451 CNT2=1 WRITE (101,3450) LDAY,XS(NCH),JK,DAYDIFF(CNT), 1KRBASE(CNT),TAUCB(CNT),TAURR(CNT),TAUCHLD(CNT),KRCONS(CNT), 2KRSC(CNT),KRBR(CNT),KRADJ(CNT),TAUCONS(CNT),TAUSC(CNT), 3TAUCADJ(CNT),KKX,KDROOTR(CNT),KLROOTR(CNT),CNT WRITE (102,3452) LDAY,XS(NCH),JK,DAYDIFF(CNT),KIBASE(CNT), 1HEIGHT(JK),CANOPY(JK),KICAN(CNT),INRCOV(JK),KIGRCOV(CNT), 2KICONS(CNT),KISC(CNT),LROOT(JK),DROOT(JK),KLROOTI(CNT), 3KDROOTI(CNT),KIADJ(CNT),KKX,CNT endif 3451 end do END DO ENDIF 3450 FORMAT (1X,I3,1X,F8.2,3X,I2,1X,F6.0,2X,F5.3,3X,F4.2,4X,F4.2,2X, 1F4.2,/, 27X,F6.4,1X,F4.2,1X,F4.2,4X,F6.4,2X,F4.2,4X,F4.2,2X,F4.2,2X,I3,/, 37X,F6.4,1X,F6.4,' CELL: ',I4) 3452 FORMAT (1X,I3,1X,F9.2,1X,I2,1X,F6.0,F10.0,1X,F4.2,5X,F5.3, 12X,F4.2,/, 113X,F4.2,2X,F4.2,2X,F9.0,1X,F4.2,5X,F4.2,3X,F4.2,/ 2,13X,F4.2,2X,F4.2,3X,F8.0,2X,I3,' CELL: ',I4) END IF C **** THE FOLLOWING PRODUCES DAILY OUTPUT IF (NSBS.EQ.1) THEN !WB if NSBS? (I believe this reads the flag for storm by !WB storm output) equals 1 ! WRITE(NUNIT,229) LDAY,PREC,VOL(NCH),XS(NCH),TOTANO3SI/1000., WRITE(NUNIT,229) LDAY,PREC,VOL(NCH),XS(NCH),ANO3SI(L-1,NCH)/1000., &ANH4SI(L-1,NCH)/1000.,ANSSI(L-1,NCH)/1000.,SPSSI(L-1,NCH)/1000., &PSSI(L-1,NCH)/1000.,ONSSI(L-1,NCH)/1000. !WB write to channel out file: LDAY = day of sim?, PREC = accumulated !WB depth of precipitation (mm), VOL(NCH) = Runoff depth for outlet i !WB for a given storm (mm), XS (NCH) = Accumulated sediment loss out !WB of catchment for outlet i for a given storm (kg/ha), ANO3SI = !WB accumulated dissolved nitrate loss from catchment draining to !WB outlet i at hydrograph line L for a given storm (g) / 1000, !WB and same for dissolve NH4, sed bound NH4 loss, dissolved P loss, !WB sed bound P loss, sed bound TKN loss IF (NCH.EQ.1) THEN WRITE(8898,231) LDAY,PREC,ANO3SI(L-1,NCH)/1000., &ANH4SI(L-1,NCH)/1000.,ANSSI(L-1,NCH)/1000.,SPSSI(L-1,NCH)/1000., &PSSI(L-1,NCH)/1000.,ONSSI(L-1,NCH)/1000. END IF END IF 231 FORMAT (1X, I3, F6.2, 1X, 5(F8.4,1X), F11.5) !TMN ANNUAL PRECIPITATION ADDED TO ANNUAL OUTPUT IF (NCH.EQ.1) THEN PCPANNUAL=PCPANNUAL+PREC !TMN ANNUAL RUNOFF ADDED TO THE ANNUAL OUTPUT RUNANNUAL=RUNANNUAL+VOL(NCH) !TMN SEDANNUAL ADDED TO USE FOR ANNUAL OUTPUT SEDANNUAL=SEDANNUAL+ XS(NCH) !TMN NO3ANNUAL (DISSOLVED NITRATE) ADDED TO USE FOR ANNUAL OUTPUT NO3ANNUAL=NO3ANNUAL+(ANO3SI(L-1,NCH)/1000.) !TMN NHWANNUAL (DISSOLOVED NH4) ADDED TO USE FOR ANNUAL OUTPUT NHWANNUAL=NHWANNUAL+(ANH4SI(L-1,NCH)/1000.) !TMN NHSANNUAL (SEDIMENT BOUND NH4) ADDED TO USE FOR ANNUAL OUTPUT NHSANNUAL=NHSANNUAL+(ANSSI(L-1,NCH)/1000.) !TMN PO4WANNUAL (DISSOLVED PO4) ADDED TO USE FOR ANNUAL OUTPUT PO4WANNUAL=PO4WANNUAL+(SPSSI(L-1,NCH)/1000.) !TMN PO4SANNUAL (SEDIMENT BOUND PO4) ADDED TO USE FOR ANNUAL OUTPUT PO4SANNUAL=PO4SANNUAL+(PSSI(L-1,NCH)/1000.) !TMN TKNANNUAL (SEDIMENT BOUND TKN) ADDED TO USE FOR ANNUAL OUTPUT TKNANNUAL=TKNANNUAL+(ONSSI(L-1,NCH)/1000.) END IF C ****THE FOLLOWING PRODUCES CUMULATIVE OUTPUT ON A SPECIFIED DAY DO 9903 NZ=1,10 9903 IF (LDYEAR.EQ.NPDAY(NZ)) &WRITE (NUNIT,229) LDAY,PREC,VOL(NCH),XS(NCH),ANO3SI(L-1,NCH)/1000 1,ANH4SI(L-1,NCH)/1000,ANSSI(L-1,NCH)/1000,SPSSI(L-1,NCH)/1000, 2ONSSI(L-1,NCH),PSSI(L-1,NCH) !WB THIS PRINT LINE ADDED 1/15/99 TO PRODUCE STORM OUTPUT ALONG !WB WITH CUMULATIVE OUTPUT DO 9901 NZ=1,10 9901 IF (LDYEAR.EQ.NPDAY(NZ)) !WB if yerbeg+1000 equals an input print option &WRITE(NUNIT,229) LDAY,TPREC,VOL1F(NCH),VOL1X(NCH),RNO3(NCH)/1000., & RNH4S(NCH)/1000.,RNH4SE(NCH)/1000.,RPHOS(NCH)/1000., & RSEDP(NCH)/1000.,RORGN(NCH)/1000. !WB write LDAY = day of sim, TPREC = accum rainfall for sim., see !WB above for remaining printout stuff C *** CONTINUE LOOP FOR EACH CHANNEL OUTLET 228 CONTINUE !WB*************************end do loop # 1684************** !TMN CHANGED FORMATTING OF THE DAILY PRECIPITATION AND RUNOFF TO HAVE !TMN TWO DECIMAL PLACES. 229 FORMAT(1X,I3,1X,F6.2,1X,F7.2,1X,F9.1,5(1X,F7.1),F10.3) C *** NRZ END C C **** INDIVIDUAL ELEMENT SEDIMENT LOSS (-) OR GAIN (+). C X=10000./DX/DX !WB overland flow width across overland flow element IF (IT.EQ.0) X=X*4.356 !WB if IT flag = 0, then multiply flow width * 4.356 C C **** OUTPUT INDIVIDUAL ELEMENT NET SEDIMENTATION AMOUNTS AND GROSS C **** STATISTICAL VALUES. C SPAERO=0. !WB min. elemental aggradation value (kg/ha) SPADEP=0. !WB max. elemental aggrad. value (kg/ha) SPASUM=0. !WB sum of sel values used to calculate SPASD SPASS=0. !WB variable used in determining SPASD C C **** COMPUTE STATISTICS ON OVERLAND FLOW ELEMENTAL SEDIMENT YIELDS. C DO 250 I=1,N SEL(I)=SEL(I)*DT*X !WB accum sed aggrad. in element i for a given storm (kg/s) !WB where dt is the time increment and x is the area of a cell in 1/ha NO3SEL(I)=NO3SEL(I)*X*DT !WB accum NO3 loss in ele i for a given storm (kg/s) NHWSEL(I)=NHWSEL(I)*X*DT !WB accum dissol NH4 loss in el i for a given storm (kg/s) NHSSEL(I)=NHSSEL(I)*X*DT !WB accum sed.-bound NH4 loss in el i for a given storm (kg/s) TKNSEL(I)=TKNSEL(I)*X*DT !WB accum sed.bound TKN loss in el i for a given storm (kg/s) PO4SEL(I)=PO4SEL(I)*X*DT !WB accum dissol P loss in el i for a given storm (kg/s) SUMSED(I)=SUMSED(I)+SEL(I) !WB accum sed. loss for cell i for the entire length of the sim (kg) SUMNO3(I)=SUMNO3(I)+NO3SEL(I) !WB accum dissol. NO3 loss for cell i for the entire length of sim (kg) SUMNHW(I)=SUMNHW(I)+NHWSEL(I) !WB accum dissol. NH4 loss for cell i for the entire length of sim (kg) SUMNHS(I)=SUMNHS(I)+NHSSEL(I) !WB accum sed. bound NH4 loss for cell i for the entire length !WB of sim (kg) SUMTKN(I)=SUMTKN(I)+TKNSEL(I) !WB accum sed. bound TKN loss for cell I for the entire length !WB of sim (kg) SUMPO4(I)=SUMPO4(I)+PO4SEL(I) !WB accum dissol P loss for cell i for entire length of the sim. (kg) 250 CONTINUE !RZ ADDED FOR CHECKING ! sel(6651)=sel(6651)*dt*x ! sumsed(6651)=sumsed(6651)+sel(6651) ! sel(6650)=sel(6650)*dt*x ! sumsed(6650)=sumsed(6650)+sel(6650) C C **** NOW, OUTPUT NET DEPOSITION FOR CHANNEL AREAS. C J=N+1 !WB J = # overland flow cells + 1 DO 260 I=J,N2 !WB do from #overland flow cells + 1 to # overland flow cells + !WB # channel flow cells SEL(I)=SEL(I)*DT 260 SUMSED(I)=SUMSED(I)+SEL(I) !WB accum sed aggradation in element i for a given storm (kg/s) * !WB time increment C C **** PLOTTING SECTION. THIS SECTION OF CODE WILL CREATE THE INPUT C **** FILE FOR SUBROUTINE HYPLT ON DEVICE 8. SOME OF THE COMMANDS C **** ARE MACHINE DEPENDENT AND ALL ARE PRESENTLY DISABLED. TO USE, C **** SIMPLY REMOVE THE C IN COLUMN 1, ADD SUBROUTINE HYPLT TO THE C **** PROGRAM, AND APPEND THE CALCOMP LIBRARY TO THE INPUT FILE. C **** THERE ARE TWO FORMAT STATEMENTS (380 AND 390) THAT MUST ALSO C **** HAVE THE COMMENT DESIGNATION REMOVED! C C L=L-1 C REWIND 8 C WRITE (8,380) L1,RMAX,QMAX,CMAX,IT,PP C C **** COPY HYDROGRAPH TO STORAGE TAPE. C C DO 270 I=1,L C 270 WRITE (8,390) T(I),RW(I),Q1(I),SSCON(I) C CALL HYPLT (L1,T,RW,Q1,SSCON,RMAX,QMAX,CMAX,IT,PP) IF (PRINHYD.EQ.1) THEN DO NCH=1,NCHAN WRITE (HYPNAM(NCH),3070) 'HYPLOT',NCH,'.OUT' 3070 FORMAT (A6,I1,A4) OPEN (UNIT=NCH+20,FILE=HYPNAM(NCH)) PRINHYD=2 ENDDO ENDIF DO NCH=1,NCHAN DO I=2,L-1 !WB DO FROM: 2 B/C BELOW SETS 1 = 0, AND TO: L-1 B/C L=NDT+1 !RZ I think this is in error - L=ndt, not ndt+1, from my testing... IF (PSSI(I,NCH).EQ.PSSI(I-1,NCH)) THEN ! IF ((PSSI(I,NCH).EQ.0).AND.(PSSI(I-1,NCH).EQ.0)) THEN PHYP(I,NCH)=0 ELSE PHYP(I,NCH)= 2((PSSI(I,NCH)-PSSI(I-1,NCH))/(PSSI(I,NCH)-PSSI(I-1,NCH) 3+QHYP(I,NCH)*1000000.))*1000000. !WB PSSI=SED BOUND P (G - G)/(G-G+M3*(E6G/M3)) * 1000000 = PPM !WB THESE VALUES WILL NEVER BE LT 0 B/C THEY ARE CUMULATIVE VALUES !WB AT WORST, THE DIFFERENCE WILL BE 0. ENDIF IF (SPSSI(I,NCH).EQ.SPSSI(I-1,NCH)) THEN ! IF ((SPSSI(I,NCH).EQ.0).AND.(SPSSI(I-1,NCH).EQ.0)) THEN DPHYP(I,NCH)=0 ELSE DPHYP(I,NCH)=((SPSSI(I,NCH)-SPSSI(I-1,NCH))/ 5(SPSSI(I,NCH)-SPSSI(I-1,NCH) 6+QHYP(I,NCH)*1000000.))*1000000. !WB SPSSI=DISSOL P ENDIF IF (ANSSI(I,NCH).EQ.ANSSI(I-1,NCH)) THEN ! IF ((ANSSI(I,NCH).EQ.0).AND.(ANSSI(I-1,NCH).EQ.0)) THEN A4SHYP(I,NCH)=0 ELSE A4SHYP(I,NCH)=((ANSSI(I,NCH)-ANSSI(I-1,NCH))/ 7(ANSSI(I,NCH)-ANSSI(I-1,NCH) 8+QHYP(I,NCH)*1000000.))*1000000. ENDIF !WB ANSSI=SED BOUND NH4 IF (ANH4SI(I,NCH).EQ.ANH4SI(I-1,NCH)) THEN ! IF ((ANH4SI(I,NCH).EQ.0).AND.(ANH4SI(I-1,NCH).EQ.0)) THEN A4DHYP(I,NCH)=0 ELSE A4DHYP(I,NCH)=((ANH4SI(I,NCH)-ANH4SI(I-1,NCH))/ 9(ANH4SI(I,NCH)-ANH4SI(I-1,NCH) 1+QHYP(I,NCH)*1000000.))*1000000. !WB ANH4SI=DISSOL NH4 ENDIF IF (ONSSI(I,NCH).EQ.ONSSI(I-1,NCH)) THEN ! IF ((ONSSI(I,NCH).EQ.0).AND.(ONSSI(I-1,NCH).EQ.0)) THEN ONHYP(I,NCH)=0 ELSE ONHYP(I,NCH)=((ONSSI(I,NCH)-ONSSI(I-1,NCH))/ 2(ONSSI(I,NCH)-ONSSI(I-1,NCH) 3+QHYP(I,NCH)*1000000.))*1000000. !WB ONSSI=SED BOUND TKN ENDIF IF (ANO3SI(I,NCH).EQ.ANO3SI(I-1,NCH)) THEN ! IF ((ANO3SI(I,NCH).EQ.0).AND.(ANO3SI(I-1,NCH).EQ.0)) THEN A3HYP(I,NCH)=0 ELSE A3HYP(I,NCH)=((ANO3SI(I,NCH)-ANO3SI(I-1,NCH))/ 3(ANO3SI(I,NCH)-ANO3SI(I-1,NCH) 4+QHYP(I,NCH)*1000000.))*1000000. !WB ANO3SI=DISSOL NO3 ENDIF ENDDO ENDDO IF (PRINHYD.NE.0) THEN IF (NIMP.GT.0) THEN IF (IMPFLAG.EQ.1) THEN WRITE (2,*) 'INPUT INDICATES IMPOUNDMENTS, HYDROGRAPH(S) WILL NOT 1 PRINT FOR THIS SIMULATION' IMPFLAG=1 ENDIF ELSE DO NCH=1,NCHAN WRITE (NCH+20,3080) 'STORM DATE = ',LDYEAR WRITE (NCH+20,3090) DO I=1,L-1 IF (RAITES.NE.1) THEN IF (I.EQ.1) WRITE (NCH+20,*) ELSE IF (I.EQ.1) WRITE (NCH+20,3100) T(I),RW(I,NCH),Q1(I,NCH) 1,Q1(I,NCH)*CONV,SSCON(I,NCH),0,0,0,0,0,0 END IF IF (I.GT.1) WRITE (NCH+20,3100) T(I),RW(I,NCH),Q1(I,NCH) 1,Q1(I,NCH)*CONV !WB T(I)=TIME (MIN), RW=RAINFALL INTENS,MM/HR,Q1=FLOW MM/HR !WB Q1*CONV = FLOW M3/S (CHECK THE CONVERSION TO Q1) 1,SSCON(I,NCH),PHYP(I,NCH),DPHYP(I,NCH),A4SHYP(I,NCH) 2,A4DHYP(I,NCH),ONHYP(I,NCH),A3HYP(I,NCH) !WB SSCON IS SED CONC IN PPM (THE KG/S UNITS CANCEL), SEE ABOVE !WB PHYP = PSSI = SED BOUND P !WB DPHYP = SPSSI=DISSOL P !WB A4SHYP = ANSSI=SED BOUND NH4 !WB A4DHYP = ANH4SI=DISSOL NH4 !WB ONHYP = ONSSI=SED BOUND TKN !WB A3HYP = ANO3SI=DISSOL NO3 END DO DO MN=1,N2 IF (POND(MN).GT.0) THEN IF (SUB(POND(MN)).EQ.0.) THEN WRITE(NCH+20,*) 'CELL',MN,'PONDDEPTH=',H2ODEPTH(POND(MN)) END IF END IF END DO !RZ above do and if-then isolates the ponds in the watershed and prints out !RZ the current pond depth at the end of the day to the HYPLOT file WRITE (NCH+20,*) WRITE (NCH+20,*) END DO ENDIF ENDIF *COMPUTE NEW SOIL MOISTURE AFTER EVERY RAINFALL EVENT * DO 6003 J=1,N !WB resets J and goes back to counting for every cell K=SOIL(J)/256 !WB # of values in rainfall hyetograph and surface type of !WB current element = soil type for element i / 256 !RZ BELOW: IF THE CELL IS URBAN, SKIP CALCULATIONS OF ASMVOL AND ASMPER IF (URB(J).EQ.1) GOTO 6003 M=MOD(SUR(J),256) ASMVOL(J)=(1.-PIV(J)*DT/TP1(K))*TP1(K)/CU1-RESWAT(K) !WB = (1-vol of air filled pore space in upper soil layer in el !WB i * time increment / porosity for soil type i ?) * porosity for !WB soil type i / (convert mm to m3) - residual water as a fraction !WB of soil porosity ASMPER(J)=ASMVOL(J)*CU1/TP1(K) !WB = above * (convert mm to m3) / porosity for soil type i ? 6003 CONTINUE ** NRZ 8/24/94 ** CONVERSIONS FOR IMPOUNDMENT MODEL ** SUM SEDIMENT BOUND NUTRIENTS FOR EACH PARTICLE SIZE CLASS DO 2610 NCH=1,NCHAN DO 261 IC=1,NPART SEDWT(NCH,IC)=SEDH(NCH,L-1,IC) !WB sed of part class i leaving catchment and entering impoundment !WB for a single rainfall event (kg) = sed of part class i and !WB hydr line L leaving catchment (kg) TSEDI(NCH,IC)=TSEDI(NCH,IC)+SEDWT(NCH,IC) !WB accum sed of part class i leaving catchment and entering !WB impoundment for sim (kg) = same + above PSEDI(NCH,IC)=PSEDI(NCH,IC)+PSEDH(NCH,L-1,IC) !WB accum sed bound P for part class i leaving catchment & !WB entering impoundment for the sim (kg) = same + sed bound P !WB for part class i and hydr line L leaving catchment (kg) ANSEDI(NCH,IC)=ANSEDI(NCH,IC)+ANSEDH(NCH,L-1,IC) !WB accum total sed. bound NH4 for part class i leaving catchment !WB & entering impoundment for the sim (kg) = same + sed bound !WB NH4 for part class i and hydr line L leaving catchment ONSEDI(NCH,IC)=ONSEDI(NCH,IC)+ONSEDH(NCH,L-1,IC) !WB accum sed. bound TKN for part class i leaving catchment and !WB entering impond. for the sim (kg) = same + sed. bound TKN !WB for part class i and hydr line L leaving catchment (kg) 261 CONTINUE 2610 RUNVOL(NCH)=VOL(NCH)/1000.*(AREA2*DBLE(NCELLS(NCH)))*10000. !WB runoff leaving catchment and entering impoundment for a single !WB rainfall event (m^3) (calc from depth of runoff * area drained !WB by network) DFWEV=0.0 !WB daily free water evap for impoundment (m) !RZ URBAN:::LASTIRR will track the last rainfall day for future reference !RZ for type 2 irrigation; also reset the irrflag to zero in preparation !RZ for the next day's calculations. IF (RAITES.EQ.1) THEN DO I=1,ICR LASTIRR(I)=LDAY END DO END IF IRRFLAG=0 ** NRZ 8/24/94 *THE FOLLOWING ENDIF INDICATES THE END OF THE IF RAITES=1 2611 ENDIF *******************end if then loop #699************************ ** NRZ 8/29/94 ** CALL FREE WATER EVAPORATION SUBROUTINE IF IMPOUNDMENT IS PRESENT IF (RAITES.EQ.0. .AND. NIMP.GE.1) CALL EVAPFW(LDAY) !WB if raintest flag equals 0 and # of impoundments greater !WB than or equal to 1 ** CALL IMPOUNDMENT MODEL FOR A CHANNEL IF STRUCTURE IS PRESENT AT ** THE END OF THAT CHANNEL IF (NIMP.GE.1) THEN C *** CONVERT PARTICLE DIAMETER FROM MM TO M DO 262 ID=1,NPART DIAM(ID)=DIAMM(ID)*0.001 !WB diameter of sed. part. size i (m) = part dia (mm) * 0.001 262 CONTINUE DO 10000 NCH=1,NCHAN IF (BASE(NCH).NE.0.) THEN !WB BASE(NCH)? DOES NOT EQUAL 0 !RZ I think this basically is checking to see if the channel !RZ has an impoundment - if so, BASE will be the base length !RZ if not, there will be no value for BASE (i.e., it will be zero) NUNIT=10+NCH !WB reset the nunit variable to equal 10 + nch counter ** SET DAILY SEDIMENT AND NUTRIENT ACCUMULATORS TO ZERO RUNO(NCH)=0.0 !WB daily runoff leaving impoundment (m^3) = 0 DTSEDO(NCH)=0.0 !WB daily total of sediment leaving impoundment = 0 DPSED(NCH)=0.0 !WB daily total of sed. bound P leaving impound = 0 DANSED(NCH)=0.0 !WB daily totalof sed bound NH4 leavin impound = 0 DONSED(NCH)=0.0 !WB daily total of sed bound TKN leaving impound = 0 DNO3O(NCH)=0.0 !WB daily total of dissol. NO3 leaving impound = 0 DNH4O(NCH)=0.0 !WB daily total of dissolv NH4 leaving impound = 0 DPHOSO(NCH)=0.0 !WB daily total of soluble P leaving impound = 0 CALL IMPOND(IDATE,RAITES,NPART,DIAM,SG,RUNVOL,SEDWT,DFWEV, & SEDOT,SEDOR,RUNO,NCH) !WB IDATE = date of sim, RAITES = raintest flag (1 = rain), !WB NPART = # of particle size classes, DIAM = diam of sediment !WB particle size i (m), SG = spec. gravity of particle type i, !WB RUNVOL = runoff leaving catchment & entering impoundment, !WB SEDWT = sed of part class i leaving catchment and !WB entering !WB impoundment for a singl rainfall event (kg), DFWEV = daily !WB free water evap for impound (m), SEDOT = sed for part class !WB i overtopping impound !WB for a single rainfal event, !WB SEDOR = sed of particle class i passing through impound !WB orifice for a single rainfall event (kg), RUNO = daily runoff !WB leaving impoundment (m^3), NCH = counter for # of channel !WB networks, or denotes which channel network ** ACCUMULATE RUNOFF FROM IMPOUNDMENT OVER SIMULATION TRUNO(NCH)=TRUNO(NCH)+RUNO(NCH) !WB cum. runoff leaving impound (m^3) = same + daily runoff !WB leaving impundment (m^3) ** CALCULATE THE TOTAL SEDIMENT DISTRIBUTION LEAVING THE IMPOUNDMENT DO 263 ID=1,NPART TSEDO(NCH,ID) = TSEDO(NCH,ID) + SEDOT(NCH,ID) + SEDOR(NCH,ID) !WB sed of part class i leaving catchment & entering impond = !WB same + sed for part class i overtopping impound + sed of !WB particle class i passing through impound orifice for a single !WB rainfall event (kg) SEDZO(NCH,ID) = SEDZO(NCH,ID) + SEDOR(NCH,ID) !WB accum sed of particle class i passing through impond for sim = !WB same + sed of particle class i passing through impound orifice !WB for a single rainfall event (kg) SEDZOT(NCH,ID) = SEDZOT(NCH,ID) + SEDOT(NCH,ID) !WB total sed for part class i overtopping impound? = same + !WB sed for part class i overtopping impound ** CALCULATE THE TOTAL MASS OF SEDIMENT LEAVING THE IMPOUNDMENT ** DAILY AND OVER THE ENTIRE SIMULATION DTSEDO(NCH) = DTSEDO(NCH) + SEDOT(NCH,ID) + SEDOR(NCH,ID) !WB daily total of sed leaving impound = same + above + above TTSEDO(NCH) = TTSEDO(NCH) + SEDOT(NCH,ID) + SEDOR(NCH,ID) !WB accum sed leaving impound = same + above + above ** CALCULATE NUTRIENT REDUCTION DUE TO SETTLING OF SEDIMENT BOUND ** SPECIES (BASED ON A RATIO OF SEDIMENT SETTLED/TOTAL SEDIMENT) ** COMPUTE DAILY AND CUMULATIVE TOTALS ** NOTE: IF SEDIMENT LEAVES THE IMPOUNDMENT ON A DAY WITH NO RAINFALL, ** SEDWT,PSEDI,ANSEDI, AND ONSEDI ARE EQUAL TO THE VALUES COMPUTED FOR ** THE LAST RAINFALL EVENT IF (SEDWT(NCH,ID).GT.0.) THEN !WB SEDWT = sed of part class i leaving catchment and entering !WB impoundment for a single rainfall event (kg) PSEDO(NCH,ID)=(SEDOT(NCH,ID)+SEDOR(NCH,ID))/SEDWT(NCH,ID)* & PSEDH(NCH,L-1,ID)/1000. !WB accum sed bound P for part class i leaving impoundment for !WB sim (kg) = above DPSED(NCH)=DPSED(NCH)+PSEDO(NCH,ID) !WB daily total of sed bound P leaving impound (kg) = same + !WB accum sed bound P for part class i leaving impond for sim (kg) PSEDT(NCH)=PSEDT(NCH)+PSEDO(NCH,ID) !WB accum sed bound P for all classes ? = same + accum sed bound !WB P for particle class i leaving impond for sim (kg) ANSEDO(NCH,ID)=(SEDOT(NCH,ID)+SEDOR(NCH,ID))/SEDWT(NCH,ID)* & ANSEDH(NCH,L-1,ID)/1000. !WB accum sed bound NH4 leaving impond on part size i for sim (kg) DANSED(NCH)=DANSED(NCH)+ANSEDO(NCH,ID) !WB daily total of sed bound NH4 leaving impound (kg) = ANSEDT(NCH)=ANSEDT(NCH)+ANSEDO(NCH,ID) !WB sim total sed bound NH4 leaving impond = ONSEDO(NCH,ID)=(SEDOT(NCH,ID)+SEDOR(NCH,ID))/SEDWT(NCH,ID)* & ONSEDH(NCH,L-1,ID)/1000. !WB accum sed bound TKN for part class i DONSED(NCH)=DONSED(NCH)+ONSEDO(NCH,ID) !WB daily total of sed bound TKN leaving impound ONSEDT(NCH)=ONSEDT(NCH)+ONSEDO(NCH,ID) !WB sim total sed bound TKN for part class i ? ENDIF 263 CONTINUE IF (RUNVOL(NCH).GT.0.) THEN !WB runoff entering impoundment (depth * area) DNO3O(NCH)=RUNO(NCH)/RUNVOL(NCH)*ANO3SI(L-1,NCH) !WB daily total of dissolved NO3 leaving impound = daily runoff !WB leaving impound / runoff entering * accum dissol NO3 loss at !WB outlet i TNO3O(NCH)=TNO3O(NCH)+DNO3O(NCH) !WB accum dissol NO3 leaving impond for si = same + daily !WB dissolved NO3 DNH4O(NCH)=RUNO(NCH)/RUNVOL(NCH)*ANH4SI(L-1,NCH) !WB daily NH4 leaving impound = daily runoff leaving impound / !WB runoff entering impound * accum dissol NH4 at outlet i TNH4O(NCH)=TNH4O(NCH)+DNH4O(NCH) !WB accum dissol NH4 leaving impound for sim = same + daily !WB dissolved NH4 DPHOSO(NCH)=RUNO(NCH)/RUNVOL(NCH)*SPSSI(L-1,NCH) !WB daily total soluble P = volume exiting impound / volume !WB entering impound * accum dissolved P loss from catchment !WB draining to outlet i for a given storm TPHOSO(NCH)=TPHOSO(NCH)+DPHOSO(NCH) !WB accum soluble P leaving impound for sim = same + daily !WB soluble P leaving impound ENDIF ** PRINT DAILY OUTPUT FOR IMPOUNDMENT IF ((RAITES.EQ.1).OR.(DTSEDO(NCH).GT.0.)) THEN !WB if raintest = 1 (rain) or daily total of sed leaving impound > 0 ** THE FOLLOWING PRODUCES CUMULATIVE OUTPUT TRUNOM(NCH)=TRUNO(NCH)/(10000.*(AREA2*DBLE(NCELLS(NCH))))*1000. !WB total runoff leaving impoundment = cum runoff leaving impound / !WB (10000 * (area of element*# cells in the channel))*1000 ** THE FOLLOWING PRODUCES DAILY OUTPUT RUNOM(NCH)=RUNO(NCH)/(10000.*(AREA2*DBLE(NCELLS(NCH))))*1000. !WB total daily runoff leaving impound = daily runoff leaving !WB impound / (10000 ( area of cell * (# of cells))*1000 ENDIF 2290 FORMAT(1X,6F9.1) 6012 FORMAT(1X,10X,F6.1,2X,F7.1,5(1X,F7.3),F10.3,/) 265 IF (IDATE.EQ.SIMDUR) THEN !WB If date of sim equals the duration of the simulation WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE FINAL SEDIMENT DISTRIBUTION ENTERING THE', & ' IMPOUNDMENT FOLLOWS:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'CLASS DIAM(MM) SEDIMENT(KG/HA)' DO 267 NSD=1,NPART 267 WRITE(NUNIT,6014) NSD,DIAMM(NSD),TSEDI(NCH,NSD)/ & (AREA2*DBLE(NCELLS(NCH))) WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE FINAL SEDIMENT DISTRIBUTION LEAVING THE', & ' OUTLET OF THE IMPOUNDMENT FOLLOWS:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'CLASS DIAM(MM) SEDIMENT(KG/HA)' DO 268 NSD=1,NPART WRITE(NUNIT,6014) NSD,DIAMM(NSD),TSEDO(NCH,NSD)/ & (AREA2*DBLE(NCELLS(NCH))) 268 CONTINUE WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE FINAL SEDIMENT DISTRIBUTION LEAVING THE', & ' ORIFICE:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'CLASS DIAM(MM) SEDIMENT(KG/HA)' DO 269 NSD=1,NPART WRITE(NUNIT,6014) NSD,DIAMM(NSD),SEDZO(NCH,NSD)/ & (AREA2*DBLE(NCELLS(NCH))) 269 CONTINUE WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE FINAL SEDIMENT DISTRIBUTION', & ' OVERTOPPING:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'CLASS DIAM(MM) SEDIMENT(KG/HA)' DO 271 NSD=1,NPART WRITE(NUNIT,6014) NSD,DIAMM(NSD),SEDZOT(NCH,NSD)/ & (AREA2*DBLE(NCELLS(NCH))) 271 CONTINUE 6014 FORMAT(3X,I1,6X,F5.3,6X,F7.1) WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE TOTAL OUTPUTS FROM THE IMPOUNDMENT ARE ', & 'AS FOLLOWS:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'DAY RAIN RUNOFF SEDIMENT NO3 DIS-NH4' & ,' SED-NH4 DIS-PO4 SED-PO4 SED-TKN' WRITE(NUNIT,*) ' MM MM KG/HA KG KG' & ,' KG KG KG KG' WRITE(NUNIT,229) LDAY,TPREC,TRUNOM(NCH),TTSEDO(NCH)/ & (AREA2*DBLE(NCELLS(NCH))),TNO3O(NCH)/1000., & TNH4O(NCH)/1000.,ANSEDT(NCH),TPHOSO(NCH)/1000., & PSEDT(NCH),ONSEDT(NCH) ** THE FOLLOWING ENDIF INDICATES THE END OF THE IF (IDATE.EQ.SIMDUR) ENDIF ** THE FOLLOWING ENDIF INDICATES THE END OF THE IF (BASE(NCH).NE.0) ENDIF 10000 CONTINUE ** THE FOLLOWING ENDIF INDICATES THE END OF THE IF (NIMP.GE.1) ENDIF ** NRZ 9/10/94 ** PRINT FINAL OUTPUTS FROM THE CATCHMENT DO 11000 NCH=1,NCHAN+1 NUNIT=10+NCH IF (IDATE.EQ.SIMDUR) THEN WRITE(NUNIT,*) WRITE(NUNIT,*) 'THE TOTAL OUTPUTS FROM THIS AREA ARE ', & 'AS FOLLOWS:' WRITE(NUNIT,*) WRITE(NUNIT,*) 'DAY RAIN RUNOFF SEDIMENT NO3 DIS-NH4' & ,' SED-NH4 DIS-PO4 SED-PO4 SED-TKN' WRITE(NUNIT,*) ' MM MM KG/HA KG KG' & ,' KG KG KG KG' WRITE(NUNIT,229) LDAY,TPREC,VOL1F(NCH),VOL1X(NCH), & RNO3(NCH)/1000.,RNH4S(NCH)/1000.,RNH4SE(NCH)/1000., & RPHOS(NCH)/1000.,RSEDP(NCH)/1000.,RORGN(NCH)/1000. !WB PRINT NEW CHANNEL WIDTHS CALCULATED BY NEW SED ROUTINE IF (NCH.LT.NCHAN+1) THEN WRITE (NUNIT,*) WRITE (NUNIT,*) 'THE FINAL WIDTHS FOR THIS CHANNEL ARE:' DO JKL=N+1,N2 KKJ=SOIL(JKL)/256 IF (CHNUMBER(JKL-N).EQ.NCH) THEN IF (CWID(JKL).GT.0) THEN WRITE (NUNIT,*) WRITE (NUNIT,3046) JKL,KKJ,CWID(JKL)+WIDINC(JKL) IF (DEPTHINC(JKL).GE.0) THEN WRITE (NUNIT,3047) DEPTHINC(JKL) !WB IF THE DEPTHINC IS GREATER THAN 0, IT INDICATES BOTTOM EROSION !WB AS THIS IS TRACKED AS A POSITIVE NUMBER. ELSE WRITE (NUNIT,3048) -1*DEPTHINC(JKL) !WB IF THE DEPTHINC IS NEGATIVE, IT INDICATES DEPOSITION, SO PRINT !WB NET DEPOSITION MASS ENDIF ELSE WRITE (NUNIT,*) WRITE (NUNIT,*) 'CHANNEL WIDTH = 0.' ENDIF ENDIF ENDDO ENDIF ENDIF !WB END OF PRINT NEW CHANNEL WIDTHS CALCULATED BY NEW SED ROUTINE 11000 CONTINUE ** NRZ 9/10/94 CALL ETP11(TEMPC,RADI,ETPMM) TETPPR=0. !WB TETPPR = unknown !RZ TOTAL TETP (POTENTIAL EVAPOTRANSPIRATION) TOTPER=0. !WB TOTPER = unknown !RZ TOTAL PERCOLATION * TOTES=0. * TOTEP=0. TOTXMO=0. !WB TOTXMO = unknown !RZ TOTAL SOIL MOISTURE (XMOI) DO 5590 J11=1,N !RZ URBAN:::if the cell is an urban cell, it has no evapotranspiration (because evapotranspiration !RZ only depletes soil water, not surface water; free water evaporation actually depletes !RZ surface water). So skip this loop for urban cells IF (URB(J11).EQ.1) GO TO 5590 K=MOD(SUR(J11),256) !WB K = # of values in rainfall hyetograph and surface type !WB of current element !RZ ???? K=cover type for current element! !WB = surface type - INT (same / 256) * 256 KK=SOIL(J11)/256 !WB KK = soil type for current element CALL EVAPO(LAI1(K),S1EP(J11),ESU(KK),TTIME(J11),S2EP(J11) & ,ETPMM,TETP,PEP(J11),ES(J11),CUMIN1(J11)) !WB LAI1 = LAI + 1?, S1EP = accum stage 1 soil evap (mm), !WB ESU = Upper limit of stage 1 of soil evap (mm day-0.5), !WB TTIME = time since stage 2 evap started (days), S2EP = !WB accum stage 2 soil evap (mm), ETPMM = Pot ET (mm), !WB TETP = Sum of ES and PEP (mm), PEP = plant transpiration (mm), !WB ES = soil evap (mm), CUMIN1 = cum infil (mm) !RZ Following: if the cell is urban, there is no soil moisture or root growth !RZ effects or percolation, therefore go to end of loop *INITIALIZING THE INITIAL CUMULATIVE INFILTRATION TO ZERO CUMIN1(J11)=0. !WB cum infil = 0 IF (XMOI(J11).LT.WP(KK)) XMOI(J11)=WP(KK) !WB THIS LINE ADDED 2/9/99 TO DETERMINE IF SOIL MOISTURE WAS !WB INADVERTENTLY CAUSING NEGATIVE STORAGE IN SOLUBP XMOI(J11)=ASMVOL(J11)+RESWAT(KK)*TP1(KK)/CU1 !WB soil moisture = ASMVOL? + residual water as a fraction of !WB soil porosity * porosity / (conv mm to m3) *EDX REPRESENTS THE MAXIMUM EVAPORATIVE DEPTH RRATIO=(EDX(KK)/DF1(KK))*(XMOI(J11)-WP(KK)) !WB RRATIO? = (max soil evap depth / depth of soil horizon)* !WB (soil moisture - WP?) IF(ES(J11).GT.RRATIO) ES(J11)=RRATIO !WB If soil evaporation greater than RRATIO?, set em equal *REDUCE THE PLANT EVAPORATION ACCORDING TO THE ROOT DEPTH IF(ROTDAY(K).GT.DF1(KK)) THEN !WB if root depth at a specific day is greater than depth of !WB soil horizon ROTRAT=DEXP(-3.065*DF1(KK)/ROTDAY(K)) !WB ROTRAT? = E^(-3.065 * depth of soil horizon) / root depth !WB at a specific day ROTR(J11)=(1.-ROTRAT)/(1.-EXP(-3.065)) !WB Ratio that reduces evap according to root depth = !WB (1-root ratio?) / (1-exp(-3.065) PEP(J11)=PEP(J11)*ROTR(J11) !WB plant transpiration = same * root depth ratio ELSE ROTR(J11)=1. !WB reset root ratio equal to 1 ENDIF CNH4(J11)=0. !WB fraction of water leaching = 0 *SOIL MOISTURE LIMITING IF(XMOI(J11).LT.WP(KK)) xmoi(j11)=wp(kk) !WB if soil moisture is less than wilting point? IF(XMOI(J11).LT.ASMLIM(KK)) THEN !WB if soil moisture is less ASMLIM? PEP(J11)=PEP(J11)*XMOI(J11)/ASMLIM(KK) !WB plant transpiration = same * soil moisture / ASMLIM ? TETP=PEP(J11)+ES(J11) !WB TETP = plant transpiration + soil evaporation IF((XMOI(J11)-WP(KK)).GT.TETP) THEN !WB if soil moisture - wilting point? is greater than plant !WB trans + soil evap ASMVOL(J11)=ASMVOL(J11)-TETP !WB ASMVOL = same - (plant trans + soil evap) TETPPR=TETPPR+TETP !WB TETPPR ? = same + (plant trans + soil evap) ELSEIF (XMOI(J11).EQ.WP(KK)) THEN !WB elseif soil moisture equal to wilting point (we set !WB it equal earlier if it's less than) ES(J11)=0. !WB soil evapo = 0 PEP(J11)=0 !WB plant trans = 0 ELSE TETP=XMOI(J11)-WP(KK) !WB (plant trans + soil evap) = soil moisture - wilting point? !WB (wilt point*porosity / conversion) PEP(J11)=PEP(J11)*TETP/(PEP(J11)+ES(J11)) !WB plant trans = same * (soil moisture - wilt point) / (plant !WB trans + soil evap) ES(J11)=ES(J11)*TETP/(PEP(J11)+ES(J11)) !WB soil evap = same*(soil moisture - wilt point) / (plant !WB trans + soil evap) ASMVOL(J11)=ASMVOL(J11)-TETP !WB ASMVOL ? = same - (soil moisture - wilting point) TETPPR=TETPPR+TETP !WB TETPPR ? = same + (soil moisture - wilting point) ENDIF TOTES=TOTES+ES(J11) !WB TOTES? = same + soil evap !RZ TOTES=total Evaporation from Soil TOTEP=TOTEP+PEP(J11) !WB TOTEP? = same + plant trans !RZ TOTEP=total Evaporation from Plants GOTO 5590 ENDIF *SOIL MOISTURE NOT LIMITING IF (XMOI(J11).GT.FCVOL(KK)) THEN !WB if soil moisture greater than field capacity XMOI2=XMOI(J11)*CU1/TP1(KK) !WB soil moisture var #2 = soil moisture * (conv mm to m3) / porosity? PERCOL=0. !WB percolation amount (mm) = 0 IF(XMOI(J11).LT.WP(KK)) xmoi(j11)=wp(kk) !WB if soil moisture is less than wilting point? !WB THIS LINE ADDED TO ALL CALL STATEMENTS DUE TO FLOAT OVERFLOWS AND !WB DOMAIN ERRORS ASSOCIATED WITH XMOI DROPPING BELOW WP 1/19/99 CALL PERCO(KS(KK),FCVOL(KK),CU,PERCOL,FCAP1(KK) & ,XMOI2,TMAX,RAITES,A(KK),J11) !WB XMOI = soil moisture, KS = sat hyd conductivity (mm/hr), !WB FCVOL = field cap, PERCOL = percolation amount, FCAP1 = !WB field cap ?, XMOI2 = soil moisture, converted and divided !WB by porosity, TMAX = max time on hyetograph, RAITES= !WB raintest flag, A = ratio of KS of top layer to KS for !WB underlying layer ASMVOL(J11) = ASMVOL(J11)-TETP-PERCOL !WB ASMVOL? = same - (soil moisture - wilting point) - percolation !WB amount XMOI(J11)=ASMVOL(J11)+RESWAT(KK)*TP1(KK)/CU1 !WB soil moisture = ASMVOL? + residual water as a fraction of !WB soil porosity * porosity / (conv mm to m3) *CNH4 REPRESENTS THE LEACHING FRACTION OF NITROGEN CNH4(J11)=(PERCOL+CNO3(J11))/(XMOI(J11)+TETP+PERCOL+CNO3(J11)) !WB leaching frac of N = (perc amt + accum perc during infil !WB (mm)) / (soil moisture + (soil moisture - wilting point) + !WB perc amt + accum perc during infil) CNO3(J11)=0. !WB reset accum perc =0 TETPPR=TETPPR+TETP !WB TETPPR? = same + (soil moisture - wilting point) TOTPER=TOTPER+PERCOL !WB total percolation? = same + perc amount TOTES=TOTES+ES(J11) !WB total soil evap? = same + soil evap TOTEP=TOTEP+PEP(J11) !WB total plant evap? = same + plant evap PERCOL=0. !WB set perc amount = 0 GOTO 5590 ENDIF IF((XMOI(J11)-WP(KK)).GT.TETP) THEN !WB soil moisture - wilt point greater than (soil moisture - wilt point) !WB this may be using a different def of TETP, as it is redefined above ASMVOL(J11)=ASMVOL(J11)-TETP TETPPR=TETPPR+TETP ELSEIF (XMOI(J11).EQ.WP(KK)) THEN ES(J11)=0. PEP(J11)=0 ELSE TETP=XMOI(J11)-WP(KK) PEP(J11)=PEP(J11)*TETP/(PEP(J11)+ES(J11)) ES(J11)=ES(J11)*TETP/(PEP(J11)+ES(J11)) ASMVOL(J11)=ASMVOL(J11)-TETP TETPPR=TETPPR+TETP ENDIF TOTES=TOTES+ES(J11) TOTEP=TOTEP+PEP(J11) TOTXMO=TOTXMO+XMOI(J11) 5590 CONTINUE 5591 FORMAT(1X,5(F10.5,1X)) CALL NITRAN(ES,FCVOL,SOIVOL,PEP,WP,N,TEMPC,ICR, & RATEMX,CU1,SOITEM,RNUTNI,RNUTAM,RNUTP,DF1,TP1) IF(IDATE.EQ.SIMDUR) THEN XCOR=365./SIMDUR WRITE(2,301) WRITE(2,302) WRITE(2,303) 301 FORMAT(///,1X,75('*')) !TMN CHANGED THE HEADING FROM READING "ANNUAL OUTPUT" TO READ !TMN "AVERAGE ANNUAL OUPUT" SINCE IT IS AN AVERAGE 302 FORMAT(///,27X,32H**** AVERAGE ANNUAL OUTPUT ****) 303 FORMAT(30X,25H**** ON A CELL BASIS ****,///) WRITE(2,309) WRITE(2,308) DO 5554 I=1,N2 WRITE (2,360) I,SUMSED(I)*XCOR,SUMNO3(I)*XCOR,SUMNHW(I)*XCOR, & SUMNHS(I)*XCOR,SUMTKN(I)*XCOR,SUMPO4(I)*XCOR,CLENO3(I)*XCOR 5554 CONTINUE ! WRITE(2,360) 6650,SUMSED(6650)*XCOR ! WRITE(2,360) 6651,SUMSED(6651)*XCOR C*** WDB 5/23/94 C*** Added by Bill Batchelor to send annual output to new file DO 9876 I=1,N WRITE (5,360) I,SUMSED(I)*XCOR,SUMNO3(I)*XCOR,SUMNHW(I)*XCOR, & SUMNHS(I)*XCOR,SUMTKN(I)*XCOR,SUMPO4(I)*XCOR,CLENO3(I)*XCOR 9876 CONTINUE WRITE(1793,*) DO I=1,35000 IF (POND(I).GT.0) THEN WRITE(1793,*) I,POND(I),NR(I),NC(I) IF (TIPE(POND(I)).EQ.3) THEN WRITE(1793,*) WRITE(1793,*) 'Infiltration Trench' WRITE(1793,382) TOTALIN(2),TOTALLOST(2),TOTALWLOST(2), 1 TOTALINF(2),TOTALEVAP(2),H2ODEPTH(2) ELSEIF (SUB(POND(I)).EQ.0) THEN WRITE(1793,*) WRITE(1793,382) TOTALIN(POND(I)),TOTALLOST(POND(I)), 1 TOTALWLOST(POND(I)),TOTALINF(POND(I)),TOTALEVAP(POND(I)), 2 H2ODEPTH(POND(I)) WRITE(1793,*) TOTALIN(POND(I)),TOTALLOST(POND(I)), 1 TOTALWLOST(POND(I)),TOTALINF(POND(I)),TOTALEVAP(POND(I)), 2 H2ODEPTH(POND(I)) WRITE(1793,*) WRITE(1793,383) TOTALSED(POND(I)),TOTALPHOS(POND(I)), 1 TOTALANIT(POND(I)),TOTALONIT(POND(I)) WRITE(1793,*) WRITE(1793,385) TOTALDEPSED(POND(I)),TOTALDEPPHOS(POND(I)), 1 TOTALDEPANI(POND(I)),TOTALDEPONI(POND(I)) WRITE(1793,*) WRITE(1793,384) TOTALOUTSED(POND(I)),TOTALOUTPHOS(POND(I)), 1 TOTALOUTANI(POND(I)),TOTALOUTONI(POND(I)) WRITE(1793,*) WRITE(1793,386) TOTALSOLP(POND(I)),TOTALSOLNH4(POND(I)), 1 TOTALSOLNO3(POND(I)) WRITE(1793,387) TOTALINFP(POND(I)),TOTALINFNH4(POND(I)), 1 TOTALINFNO3(POND(I)),TOTALLOSTSOLP(POND(I)), 2 TOTALLOSTSOLNH4(POND(I)),TOTALLOSTSOLNO3(POND(I)) WRITE(1793,389) SOLP(POND(I)),SOLNH4(POND(I)),SOLNO3(POND(I)) END IF END IF END DO 389 FORMAT (1X,'Current Phosphorus=',F9.5,' Current NH4=',F9.5,' 1Current NO3=',F9.5) 388 FORMAT (1X,'Current Sediment=',F9.5,' Current Phosphorus=',F9.5, 1' Current A-Nit=',F9.5,/,' Current O-Nit=',F9.5) 386 FORMAT (1X,'Soluble P inflow=',F9.7,' Soluble NH4 inflow=',F9.7, 1' Soluble NO3 inflow=',F9.7) 387 FORMAT (1X,'Infiltrated P=',F9.7,' Infiltrated NH4=',F9.7,' Infi 1ltrated NO3=',F9.7,/,' Lost P=',F9.7,' Lost NH4=',F9.7,' Lost N 1O3=',F9.7) 385 FORMAT (1X,'Deposited Sediment=',F9.3,' Deposited Phosphorus=', 1F9.5,' Deposited A-Nit=',F9.5,/,' Deposited O-Nit=',F9.5) 384 FORMAT (1X,'Sediment Outflow=',F9.3,' Phosphorus Outflow=',F9.5, 1' A-Nit Outflow=',F9.5,/,' O-Nit Outflow=',F9.5) 383 FORMAT (1X,'Sediment Inflow=',F9.3,' Phosphorus Inflow=',F9.5, 1' A-Nit Inflow=',F9.5,/,' O-Nit Inflow=',F9.5) 382 FORMAT (1X,'Water Inflow=',F10.3,' Pipe Outflow=',F9.3, 1' Weir Outflow=',F9.3,/,' Total Infiltration=',F9.3,' Total Eva 1poration=',F9.5,' Current Water Depth=',F9.3) C** WDB 5/23/94 ENDIF C *** NRZ C *** PRINT CELLULAR OUTPUT FILE IF REQUESTED FOR A CERTAIN DAY DO 9877 NZ=1,10 IF (LDYEAR.EQ.NPDAY(NZ)) THEN XCOR = 365./DBLE(IDATE) NFUNIT=30+NZ WRITE(XPFIL(NZ),9900) NPDAY(NZ) 9900 FORMAT (I7) OPEN (NFUNIT,FILE=XPFIL(NZ)) DO 9878 I=1,N WRITE (NFUNIT,360) I,SUMSED(I)*XCOR,SUMNO3(I)*XCOR,SUMNHW(I) & *XCOR,SUMNHS(I)*XCOR,SUMTKN(I)*XCOR,SUMPO4(I)*XCOR,CLENO3(I) & *XCOR 9878 CONTINUE CLOSE (NFUNIT) ENDIF 9877 CONTINUE DO 29293 I=1,N !TMN ADDED TO SUM THE TOTAL NITROGEN THAT IS LEACHED ANNUALLY LNO3DAY=LNO3DAY+CLENO3(I) 29293 CONTINUE LNO3ANNUAL=LNO3ANNUAL+LNO3DAY-CUMMULATIVE CUMMULATIVE=LNO3DAY LNO3DAY=0.0 !TMN ADDED COUNTER FOR THE ANNUAL OUTPUT IF(LDAY.EQ.365 .AND. MOD(YERBEG,4).NE.0.) THEN ANNUALOUT=1 ELSEIF (LDAY.EQ.366 .AND. MOD(YERBEG,4).EQ.0) THEN ANNUALOUT=1 ENDIF !TMN WRITE ANNUAL OUTPUT TO 'ANNUAL.OUT' (UNIT=300) ! IF(MOD(IDATE,365).EQ.0)THEN IF (ANNUALOUT.EQ.1)THEN WRITE (300,988)YERBEG,PCPANNUAL,RUNANNUAL, & SEDANNUAL,NO3ANNUAL,NHWANNUAL, & NHSANNUAL,PO4WANNUAL,PO4SANNUAL,TKNANNUAL,LNO3ANNUAL 988 FORMAT(1X,I4,2X,F8.2,1X,F6.1,1X,F10.1,1X,F9.4,2(2X,F7.2), &2(3X,F7.2),3X,F10.3,1X,F10.2) !TMN SET ANNUAL ACCUMULATION TO ZERO FOR NEW YEAR PCPANNUAL=0 RUNANNUAL=0 SEDANNUAL=0 NO3ANNUAL=0 NHWANNUAL=0 NHSANNUAL=0 PO4WANNUAL=0 PO4SANNUAL=0 TKNANNUAL=0 LNO3ANNUAL=0 !TMN RESET THE ANNUAL COUNTER TO ZERO ANNUALOUT=0 ENDIF 5555 CONTINUE CLOSE(5) C *** SET IEEE ARITHMETIC FLAG TO 0 FOR SUN-OS FORTRAN 77 COMPILER * ieeer=ieee_flags('clear', 'exception', 'all', out) C C **** FORMATS. C 280 FORMAT (19A4) 290 FORMAT (1X,52H DISTRIBUTED HYDROLOGIC AND WATER QUALITY SIMULATION 1,/9X,37HBY ANSWERS VER 19 AUG 99 BETA RELEASE/19A4) 300 FORMAT (/,15X,'OUTLET HYDROGRAPHS--VER 4.940001',/,31X,'YIELD',9X, 1'CONCENTRATIONS -',A4,/,2X,' TIME',2X,'RAINFALL',2X,'RUNOFF',4X,'S 2EDIMENT',3X,'SEDIMENT PHOSPHORUS SOLPHOS',/,1X,' MIN.',2X,2A4, 31X,2A4,5X,A4,18X,'(MG)',6X,'(G)') * 309 FORMAT(5X,'TIME',5X,'SEDIMENT',5X,'SOLUBLE',6X,'SEDIMENT') * 308 FORMAT(13X,'BOUND NH4',7X,'NH4',7X,'BOUND ORG-N',5X,'NITRATE') * 307 FORMAT(5X,'(MN)',6X,'(G)',10X,'(G)',10X,'(G)',11X,'G') C *** NRZ C *** SIGNIFIED DISSOLVED PO4 IN CELLULAR OUTPUT ("DIS-PO4", NOT "PO4") 309 FORMAT(1X,7HELE NO ,1X,9H SEDIMENT,1X,9H NO3 ,1X,9H SOL-NH4 , &1X,9H SED-NH4 ,1X,9H SED-TKN ,1X,9H DIS-PO4 ,10H NO3 LEACH ) 308 FORMAT(1X,7H ,1X,9H KG/HA ,1X,9H KG/HA ,1X,9H KG/HA , &1X,9H KG/HA ,1X,9H KG/HA ,1X,9H KG/HA ,9H KG/HA ) 310 FORMAT (1X,F7.1,F8.2,F10.4,2F11.0,1X,F12.3,1X,F12.5) 311 FORMAT(1X,F7.1,1X,F12.4,1X,F12.4,1X,F12.4,2X,F12.4) 320 FORMAT (4X,28HRUNOFF VOLUME PREDICTED FROM,F7.2,A4,14H OF RAINFALL 1 =,F7.3,A4/15X,19HAVERAGE SOIL LOSS =,F7.0,1X,2A4) 330 FORMAT (///5X,48HMEAN FLOW DEPTH GREATER THAN EXPECTED AT ELEMENT, 1I5/56H CONDITION OCCURRED BECAUSE THIS ELEMENT'S SLOPE IS MUCH, 231H LESS THAN WATERSHED AVERAGE OR,/,28H CIRCULAR FLOW PATTERNS 3ARE ,58H PRESENT IN THIS VICINITY. RECOMMENDED CORRECTIVE ACTION: 4,/' INCREASE EXPECTED PEAK RUNOFF VALUE (SF) IN SUBROUTINE DATA', 510H OR MODIFY,/,24HELEMENT FLOW DIRECTIONS.) 350 FORMAT (1X,'MAX EROSION RATE =',F7.0,2A4,2X,'MAX DEPOSITION RATE = 1',F7.0,2A4,/,23X,'STD. DEV. =',F7.0,2A4,//,24X,'CHANNEL DEPOSITION 2 --',A4,/,4(4X,'NO. AMOUNT')) 360 FORMAT (I7,1X,F9.0,6(1X,F9.3)) 370 FORMAT (21H STRUCTURAL PRACTICE,I3,32H REDUCED TOTAL SEDIMENT YIE 1LD BY,F9.0,A4) C 380 FORMAT (I4,2F7.2,F7.0,I3/12A4) C 390 FORMAT (3F10.2,F10.0) 405 FORMAT(/20X,26HPARTICLE SIZE DISTRIBUTION/ *24X,18HOF ERODED SEDIMENT/) 410 FORMAT(17X,15HPARTICLE CLASS ,I1,2H =,F6.2,8H PERCENT) C 5560 FORMAT(1X,I4,1X,I4,1X,I4,1X,I1,1X,I1) C *** NRZ 9/12/94 C *** MODIFY FORMAT LINE FOR FERTILIZER INPUT C 6010 FORMAT (1X,F9.4,1X,F9.4,1X,F9.4) 6010 FORMAT (1X,I4,1X,I3,1X,I5,3(1X,F9.4)) C *** NRZ 9/12/94 2570 FORMAT(2X,I4,1X,I3,3X,F7.2,2X,F7.3,2X,F7.0,3X,F7.4,2X,F7.4,5X, &F7.4,3X,F7.4,/,55X,F7.4,5X,F7.4) 2580 FORMAT(2X,I4,1X,I3,3X,F7.2,2X,F7.3,2X,F7.0,3X,F7.3,2X,F7.3,5X, &F7.3,3X,F7.3,/,55X,F7.3,5X,F7.3) !WB BEGIN NEW SED ROUTINE ERROR MESSAGES 2582 FORMAT ('GROWTH FACTOR IS < 0 OR >1',F5.2) 2584 FORMAT ('MAXIMUM PLANT HEIGHT <0 OR > 3.0 M',F5.2) 2586 FORMAT ('THE HEIGHT FACTOR IS <0 OR >1',F5.2,/,'PLEASE CHECK THE 1GROWTH FACTOR AND MAXIMUM PLANT HEIGHT') 2588 FORMAT ('THE AREA UNDER THE CANOPY IS EITHER < 0 OR > 100%', 1F6.2) 2590 FORMAT ('THE AREA UNDER THE CANOPY FACTOR IS <0 OR >1',F5.2,/, 1'PLEASE CHECK THE GROWTH FACTOR AND AREA UNDER CANOPY') 2592 FORMAT ('AN ERROR HAS OCCURRED. PLEASE CHECK THE PRIMARY' 1,/,'OUTPUT FILE.') 2594 FORMAT ('ERROR IN ROUTINE THAT CALCULATES THE COVER 1 FOR THE ',/,'CURRENT DAY. PLEASE CHECK YOUR ROTATION 2 PARAMETERS.') 2595 FORMAT ('THE ROTATION LENGTH IS GREATER THAN ONE YEAR. THIS ',/, 1'MAY CAUSE ERRORS IN THE PLANT GROWTH SCHEME. PLEASE LIMIT',/, 2' ROTATIONS TO LESS THAN ONE YEAR IN LENGTH.') 2596 FORMAT ('ONE OF THE SOIL VARIABLES IS < 0, >1 (>100%), OR BULK' 1,/,' DENSITY IS INPUT IN KG/M3 INSTEAD OF G/CM3',/,'IT IS 2CLAY =',F5.2,' SAND =',F5.2,' SILT=',F5.2,' VFS =',F5.2, 3' ORGMAT=',F5.2) 2597 FORMAT('MASS OF C.F. BY WEIGHT =',F5.2,' BULK DENSITY =' 4,F5.2,/,'IT OCCURRED AT CELL # ',I3) 2598 FORMAT ('KRBASE GT 0.05',' CNT =',I3,' KRBASE= ',F8.4, 1/,' AND HAS BEEN SET EQUAL TO 0.05.') 3000 FORMAT ('KRBASE LT 0.002',' CNT =',I3,' KRBASE= ',F8.4, 1/,' AND HAS BEEN SET EQUAL TO 0.002.') 3002 FORMAT ('TAUCB GT 7.0',' CNT =',I3,' TAUCB= ',F8.4, 1/,' AND HAS BEEN SET TO 7.0') 3004 FORMAT ('TAUCB LT 0.3',' CNT =',I3,' TAUCB= ',F8.4, 1/,' AND HAS BEEN SET TO 0.3') 3005 FORMAT ('THE BURIED RESIDUE ADJUSTMENT IS <0 OR >1, AND THIS',/, 1'INDICATES THAT A PROGRAM ERROR HAS OCCURRED. KRBR = ',F5.2,/, 2' AT CELL # ',I3) 3006 FORMAT ('THE RANDOM ROUGHNESS APPEARS TO BE INPUT IN M.',/, 1' THE RANDOM ROUGHNESS IS (IN METERS):',F10.5,/, 2' THE CROP SERIES # IS: ',I3,/,' PLEASE BE 2 CERTAIN THAT THE ROUGHNESS IS INPUT IN MM.') 3008 FORMAT ('THE RANDOM ROUGHNESS ADJUSTMENT FACTOR INDICATES THAT',/, 1' RANDOM ROUGHNESS EXCEEDS 200 MM, OR IS INPUT IN METERS.',/, 2' PLEASE CHANGE THIS.',/, 3' RR ADJUSTMENT =',F5.2,' THE CELL IS: ',I3) 3010 FORMAT ('KIBASE GT 12,000,000 AT CELL:',' CNT =',I3,' 1KIBASE = ',F8.4,/,' AND HAS BEEN SET TO 12,000,000.') 3012 FORMAT ('KIBASE LT 500,000 AT CELL:',' CNT =',I3,' 1KIBASE =',F8.4,/,' AND HAS BEEN SET TO 500,000.') 3014 FORMAT ('FIELD CAPACITY TIMES POROSITY (FCFRAC) IS GT 1.' 1,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR SOIL #: ',I3) 3016 FORMAT ('THE SOIL CONSOLIDATION FACTOR KRCONS IS LT 0 OR GT 1.' 1,/,' ITS VALUE IS: ',F6.3,' AT CELL #: ',I5) 3018 FORMAT ('THE SEALING AND CRUSTING FACTOR IS LT 0 OR GT 1.' 1,/,' ITS VALUE IS: ',F6.3,' AT CELL #: ',I5) 3020 FORMAT ('THE ADJUSTED RILL ERODIBILITY IS LT 0.' 1,/,' ITS VALUE IS: ',F6.3,' AT CELL #: ',I5) 3022 FORMAT ('THE ADJUSTED RILL ERODIBILITY IS GT 1.' 1,/,'ITS VALUES IS: ',F6.3,' AT CELL #: ',I5) 3030 FORMAT ('TAUCONS LT 0, OR TAUCADJ GT 15.',/,' TAUCONS: ',F10.5,/, 1' CELL #: ',I4) 3032 FORMAT ('HEIGHT GT 3.0 M, OR CANOPY FACTOR GT 1.0',/,' 1 CELL #: ',I3) 3034 FORMAT ('THE INTERRILL CANOPY FACTOR IS LT 0 OR IS GT 1.' 1,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR CELL #: ',I3) 3036 FORMAT ('THE FRACTION OF INTERRILL AREA COVERED BY GROUND 1 COVER IS 0 OR IS GT 1.',/,' AND IT HAS BEEN SET TO 0 OR 1 ' 2,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR CROP #: ',I3) 3038 FORMAT ('THE INTERRILL COVER FACTOR IS LT 0 OR IS GT 1.' 1,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR CELL #: ',I3) 3040 FORMAT ('THE VARIABLES BELOW HAVE CAUSED THE INTERRILL CONSOLI 1DATION',/,' FACTOR TO BE NEGATIVE, PLEASE CHECK THEM.',/, 21X,14HSAND FRACTION=,1X,F5.3,3X,24HORGANIC MATTER FRACTION= 3,1X,F5.3,/,1X,15HFIELD CAPACITY=,1X,F5.3) 3042 FORMAT ('THE INTERRILL SEALING AND CRUSTING FACTOR ' 1,/,' IS LT 0 OR IS GT 1.' 2,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR CELL #: ',I3) 3044 FORMAT ('THE ADJUSTED INTERRILL ERODIBILITY FACTOR IS LT 0.' 1,/,' THE VALUE IS: ',F5.3,' AND IT OCCURRED FOR CELL #: ',I3) 3046 FORMAT (11HCELL NO. = ,I5,2X,12HSOIL TYPE = ,I2,2X, 114HFINAL WIDTH = ,F8.3) 3047 FORMAT (14HERODED DEPTH =,2X,F7.4) 3048 FORMAT (17HDEPOSITED DEPTH =,2X,F7.4) 3049 FORMAT ('THE INTERILL COVER IS LESS THAN 0.' 1,/,' ITS VALUE IS ',F6.3,' FOR CROP # :',I3) 3050 FORMAT ('THE DEAD ROOT FACTOR IS LESS THAN -1, OR GT 1' 1,/,' ITS VALUE IS ',F6.3,' FOR CROP # :',I3) 3052 FORMAT ('THE LIVE ROOT FACTOR IS LESS THAN 0, OR GT 1' 1,/,' ITS VALUE IS ',F6.3,' FOR CROP # :',I3) 3054 FORMAT ('KLROOTR LT 0 OR GT 1 :',F6.3,3X,'FOR CROP #',3X,I3 1,' AT CELL # ',3X,I4) 3056 FORMAT ('KDROOTR LT 0 OR GT 1 :',F6.3,3X,'FOR CROP #',3X,I3 1,' AT CELL # ',3X,I4) 3058 FORMAT ('KLROOTI LT 0 OR GT 1 :',F6.3,3X,'FOR CROP #',3X,I3 1,' AT CELL # ',3X,I4) 3060 FORMAT ('KDROOTI LT 0 OR GT 1 :',F6.3,3X,'FOR CROP #',3X,I3 1,' AT CELL # ',3X,I4) 3080 FORMAT (A13,I8) 3090 FORMAT (12X, 'RAINFALL', 22X, 'SEDIMENT', 2X,/, 6X 1,'TIME', 1X, 'INTENSITY', 6X, 'FLOW', 6X, 'FLOW', 5X, 'CONC.' 2,3X,'SED-PO4',3X,'DIS-PO4',3X,'SED-NH4',3X,'DIS-NH4',3X 3,'SED-TKN',3X,'DIS-NO3',/, 6X, 'MIN.', 5X, 'MM/HR', 5X, 'MM/HR' 4,7X,'CMS', 7X, 'PPM',7X,'PPM',7X,'PPM',7X,'PPM',7X,'PPM',7X,'PPM' 5,7X,'PPM') 3100 FORMAT (11(1X,F9.2)) 9000 END C **** NRZ 7/23/95 C **** ADD IEEE HANDLER * integer function handler(sig,code,context) * integer sig, code, context(5) * write (*, '("exception at pc", I5 )' ) context(5) * end SUBROUTINE XDATA (NDT,KPR,N,CONV,CU,SF,IT,NN,ICR,NFI,CU2,ISTRUC, &SB,TMIN,TMAX,NRG,DX,GRF,NEXP,DC,PP,FILTS,CWID,AREA,AREA2,DT,NMAX, &CU1,DAYBEG,SIMDUR,ISR,YERBEG,CLAYAV,CALLBMP,CROP) IMPLICIT DOUBLE PRECISION A-H,O-Z C C ****** SUBROUTINE TO INPUT WATERSHED DATA. C C *** NRZ 9/12/94 C *** ADD VARIABLES FOR FERTILIZER INPUT COMMON /FERT/ IFERT C *** NRZ 9/12/94 COMMON /ZSEDI/ NPART,NWASH,NWASH1 COMMON /ZSEDR/ VISCOS,AGRAV,SWH2O,YALCON,SE(8),VS(35000),DIA(8), 1SG(8),FV(8),CY1(8),CY2(8),CY4(8),DIAMM(8),EQSDIA(8),EDMM(8), 2F(30,8),CE1,CE2,CE3,CE4,CE5,CE6 !WB Changed F(10,8) to F(30,8) to accomodate 30 soil types COMMON /CUMIN/ CUMIN1(35000),rbit0(35000),testi(35000),timpon 1(35000),tpon(35000) C C **** MAXIMUM NUMBER OF SOIL TYPES IS 30. C COMMON /CSOIL/ A(30),FC(30),GWC(30) COMMON /GRAMPT/ CL(30),SA(30),ST(30),OM(30),AC(30) & ,AO(30),BC(30),BO(30),PHI(30),VCF(30),WCF(30),CFC(30), & CEC(30),EAC(30),PHIC(30),XF(30),PSIF(30),CBF(30), & THETAR(30),KS(30),CF(30),Z(30),LF(30),CS(30),SCF(30), & CRC(30),KE(30,30),ZC(30),BD(30) C **** NRZ 9/12/94 C **** ADD VARIABLES TO ENTER SATURATED HYDRAULIC CONDUCTIVITY DIMENSION SK(30),KOPT(30) C **** NRZ 9/12/94 COMMON /ETPES/LAI(20,11),ESU(30),LAI1(20),POTLAI(20) &,SUMLAI(20) COMMON /EDX/ EDX(30) COMMON /ROT/ IROT1,IROT(20,644) INTEGER IROT1,IROT DOUBLE PRECISION KS,KE,LF,LAI,LAI1 C *** NRZ 9/15/94 C *** CHANGE DIMENSION OF SOME VARIABLES TO CORRESPOND WITH C *** NMAX+ISTRUC+1+NCHAN COMMON /PHOS1/ P0SOIL(35000),SSA(30,8),SSAT(30),EDI(35000), & P0(35000,8),ERP(8),STOLD(35000,8),SEDNEW(35000,8),PPT(35000,8), & PI(35050,8),PSEL(35000),STNEW(8),P2(8),PCELL(35000,8),PE(8) & ,DRFT(8) COMMON/NITRO1/ A0SOIL(35000),ANPT(35000,8),ANI(35050,8), & ANSEL(35000),AN2(8),ANCELL(35000,8),ANE(8),AN0(35000,8) & ,CNH4(35000) COMMON/NITRO2/ O0SOIL(35000),ONPT(35000,8),ONI(35050,8), & ONSEL(35000),ON2(8),ONCELL(35000,8),ONE(8),ON0(35000,8) COMMON /SOLUB/ SP2(35000),PEXT(35000),PK(30) & ,RBETA(30),SPI(35050),CGEN1(35000) & ,T13(35000),SPSP(35000) COMMON/WATNH4/VOLSZ(35000),SZNH4(35000),AINH4(35050),STONH4(35000) & ,OUTNH4(35000),EDINH4(35000),VOLSZ1(35000),VOLSOI(35000) COMMON /TRANSF/POTMIN(35000),SOILN(35000),XMIN(35000),AMON(35000) & ,NIT(35000),DNI(35000),UPNH4(35000),UPNO3(35000),TDMN2(35000) & ,ROTR(35000),RFON(35000) DOUBLE PRECISION XMIN,NIT COMMON /TRAP/PMINP(35000),SOILP(35000),MINP(35000),PLAB(35000), & UPPHOS(35000),TDMP2(35000),SORGP(35000),PSOL(35000), & EDILAB(35000) DOUBLE PRECISION MINP COMMON/NO3/SZNO3(35000),AINO3(35050),STONO3(35000),OUTNO3(35000) & ,CNO3(35000),EDINO3(35000),CLENO3(35000) C *** NRZ 9/15/94 COMMON /ASMF/ ASMBF(30),FCAP1(30),TP1(30),RESWAT(30),DF1(30) DIMENSION TP(30), DF(30), ASM(30), FCAP(30) C C **** MAXIMUM NUMBER OF SURFACE AND CROP TYPES IS 20. C COMMON /CROUGH/ ROUGH(20),HU(20),DIR(21),PIT(40,20),PER(20) !WB I'm not sure if the below is still true. C C **** MAXIMUM NUMBER OF OVERLAND ELEMENTS PLUS CHANNEL ELEMENTS C **** IS 50. !WB below is no longer true becuase they aren't equivalenced anymore C ****** IT IS EXPECTED THAT ARRAY "IEL" (IN SUBROUTINE DATA) WILL C ****** BE OF SUCH A SIZE THAT IT WILL OVERLAY (BE EQUIVALENCED TO) C ****** THE SPACE IN ARRAYS SI AND QI TOGETHER. THEREFORE IT IS C ****** NECESSARY THAT THESE TWO ARRAYS BE KEPT ADJACENT IN THEIR C ****** COMMON BLOCK. NOTE: THE ACTUAL NUMBER OF ELEMENTS THAT C ****** CAN BE DIMENSIONED IN IEL WILL DEPEND ON THE WORD LENGTH C ****** OF THE MACHINE BEING USED, E.G. ON A MACHINE WHICH USES C ****** A SINGLE WORD INTEGER AND A DOUBLE WORD REAL, THE NUMBER C ****** OF ELEMENTS IN IEL CAN BE FOUR TIMES THE NUMBER OF ELEMENTS C ****** IN ARRAY SI. C C ****** NRZ 9/15/94 C ****** DIMENSIONS OF SI AND QI ARE CHANGED TO CORRESPOND WITH C ****** NMAX+ISTRUC+1+NCHAN C COMMON /CFLOW/ Q(35000),RFL(35000),FLINS(35000),SS(35000), 1PIV(35000),B(35000),DR(35000), 2SL(35000),SEL(35000),SI(35050,8),QI(35050),DIN(35000), 3SST(35000,8),PIVTMP(35000),SSTMP(35000) COMMON /CFLOW2/NR(35000),NC(35000),S(35000) C *** NRZ C *** ADD COMMON BLOCK FOR PERCENTAGE OF CELL AREA "LEAKING" OUTSIDE THE C *** WATERSHED COMMON /LEAKY/ OUTSID C *** NRZ END !WB I'm not so sure that the below is still true. See above C C ****** ARRAYS SI AND QI MUST BE DIMENSIONED TO A SIZE = NMAX+ISTRUC+2 C ****** TO HOLD, IN ORDER, SEDIMENT AND FLOW FROM THE WATERSHED OUTLET C ****** ELEMENT, STRUCTURAL PRACTICES AND ANY "LEAKY" ELEMENTS. C DIMENSION CROP(20,2), RN(20), DIRM(20), CBAR(20), SPER(30), NSTRUC 1(4), STRNAM(3,4) CHARACTER*4 CROP COMMON / CROPAD/ DIRM2(20) C C **** MAXIMUM NUMBER OF RAINGAGES IS 40 WITH 200 VALUES PER GAGE. C COMMON /CRGAGE/ RC(40,200),TC(40,200),R(40,21),FRA(40),JTR(40), 1RATE(40),SR(40),NF(40),RATE2(40) DIMENSION IRR(40),IG(40),XDATE(2) DIMENSION IEL(3,300,24), ITEMP(24) DIMENSION IELC(3,300,2), ITEMPC(2) DIMENSION FILTS(35000), CWID(35000),CWIDTMP(35000) COMMON /CSURF/ SUR(35000),RANE(35000),SOIL(35000) COMMON /PARTITION/PKDA(30),PKDP(30),PSP(30) COMMON /PLANTN/DATPLA(20),DATHAR(20),CP1(20),CP2(20),DMY(20) & ,YP(20),ROTMAX(20),ROTDAY(20),RLAIMX(20) & ,RES(20),RES20(20),RES90(20) COMMON /WETDEPOSIT/ NO3ZDEP(21,4),WATNHDEP(21,4),SOLUBPDEP(21,4), 1TSSDEP(21,4) DOUBLE PRECISION NO3ZDEP, WATNHDEP, SOLUBPDEP,TSSDEP COMMON /ATMDEPO/ ATMDEP(21,4),TKNDEP(21,4),AMNDEP(21,4), 1SEPDEP(21,4) ** NRZ (8/29/94) ** ADD COMMON STATEMENT FOR IMPOUNDMENT DIMENSIONS COMMON /IMPDIM/ BASE,WIDTH,SLOPE,ORIF,CI,FI,MAXHGT,NIMP DOUBLE PRECISION BASE(10),WIDTH(10),SLOPE(10),ORIF(10),CI(10), &FI(10),MAXHGT(10) COMMON /FWATER/ AFWEV,DFWEV C *** ADD COMMON BLOCK FOR EXTRA OUTPUT OPTIONS COMMON /XPRINT/ NSBS,NPDAY(10) ** NRZ (8/29/94) INTEGER SUR,SOIL,TIAL(35000),RANE,CHAN(35000),DATPLA,DATHAR C NRZ 9/5/94 C ADDED VARIABLES FOR CHANNEL NETWORKS COMMON /OUTLET/ NCHAN,NIOUT(9),NJOUT(9),MOUT(9),CHNUM(35000), & CHOUT(9),NCELLS(9),CHNUMBER(35000) INTEGER CHNUM,CHOUT,CHNUMBER CHARACTER*13 OUTFIL(10) DIMENSION LCC(35000),LCR(35000) C NRZ 9/5/94 INTEGER DAYBEG,SIMDUR,YERBEG,ROTMAX,ROTDAY C C **** MAXIMUM NUMBER OF CHANNEL TYPES IS 30. C !WB BEGINNING OF NEW VARIABLES FOR NEW DETACHMENT ROUTINES !WB soil variables: COMMON/SOILVAR/CLAY(30),SAND(30),SILT(30),VFSPER(30),VFS(30), 1ORGMAT(30),MASSCF(30),RANROU(30),RANROUM(30) DOUBLE PRECISION MASSCF !WB rill erodibility variables: COMMON/RILLVARS/KRBASE(35000),KRBR(35000),BR(20),BURRES(20), 1KRADJHLD(35000),KRCONS(35000),KRSC(35000),KRADJ(35000) DOUBLE PRECISION KRBASE,KRBR,KRADJHLD,KRCONS,KRSC,KRADJ !WB critical shear variables: COMMON/CRTSHEAR/TAUCB(35000),TAURR(35000),TAUCHLD(35000),TAUCONS 1(35000),TAUSC(35000),TAUCADJ(35000),TAUEFF !WB interrill erodibility variables: COMMON/IRILLVARS/KIBASE(35000),KICAN(35000),KIGRCOV(35000),KICONS 1(35000),KISC(35000),KIADJ(35000),CANOPY(20),AUCFACT(20), 2HEIGHT(20),MAXPLHGT(20),HGTFACT(20),GROWFACT(20) DOUBLE PRECISION KIBASE,KICAN,KIGRCOV,KICONS,KISC,KIADJ,MAXPLHGT !WB interrill cover common block: COMMON /IRILLCOV/ INRCOV(20),INRCOVI(20),INRCOVF(20),INRFACT(20), 1LROOT(21),DROOT(21),KDROOTI(35000),KLROOTI(35000),DDROOTI(21), 2DDROOTF(21),DDRTFAC(21),LRFAC(21),LIVEROOT(21),KDROOTR(35000), 3KLROOTR(35000) DOUBLE PRECISION INRCOV,INRCOVI,INRCOVF,INRFACT,LROOT,KDROOTI, 1KLROOTI,LRFAC,LIVEROOT,KDROOTR,KLROOTR !WB rill erosion variables: COMMON/RILLEROS/NORILLS,RILLSPC(20),QEFF,RILLWID,MNSOIL(21), 1MNTOT(21),FLOWDEP,HYDRAD,DCAP,FCFRAC(30),FOFD,FPOFD,FDPOFD, 2FLDEPOLD,MNCHNSL(35000),MNCHNTOT(35000),MNCS(30),MNCT(30),MNCSTMP 3(35000),MNCTTMP(35000),MAXWID,NOTILL(21),NOEROS(21),DWSOIL, 4HYDRADOLD(35000) DOUBLE PRECISION MNSOIL,MNTOT,MNCHNSL,MNCHNTOT,MNCS,MNCT,MNCSTMP, 1MNCTTMP,NORILLS,MAXWID !WB interrill erosion variables COMMON /IRILLEROS/RNOFIR,SEDDR(35000,8),DIINT(35000,8),DETR(8) 1,DETF(8),DACT(35000,8) !WB PLANT GROWTH VARIABLES COMMON /PLANTS/ DAYNOW(35000),YEARNOW(35000),DYYRNOW 1(35000),DAYTHEN(35000),YEARTHEN(35000),DYYRTHEN(35000), 2DAYDIFF(35000),BEGROTDT(35000) !WB CHANNEL BOTTOM EROSION VARIABLES COMMON /CHANEROS/WIDINC(35000),DOWNRATE(35000), 1DEPTHINC(35000),IMPERM(30),ROCKBOT(35000),RBTEMP(35000), 2BULKDENS(30),CHNSOIL(35000),CHNSL(35000),CHNSLTMP(35000) 3,DEPRATE(35000),DEPPREV(35000),CONSTHLD(35000),XHOLD(35000) 4,CONSTTMP(35000),XTMP(35000) DIMENSION CHNURB(35000),CHNURBTMP(35000) COMMON /ARMOUR/ARMOUR(35000),NOERODE(35000) 1,NERODTMP(35000) !WB HYDROGRAPH PLOT VARIABLES COMMON /HYPLT/PRINHYD,IMPFLAG,QHYP(101,10),PHYP(101,10) 1,DPHYP(101,10),A4SHYP(101,10),A4DHYP(101,10),ONHYP(101,10) 2,A3HYP(101,10) CHARACTER(11) HYPNAM(10) DOUBLE PRECISION DIFF,RGTSID,LFTSID,IMPERM,NOERODE,NERODTMP INTEGER CNT,CNTER,CNTFLAG,NOTILL,INIT,NOEROS,CHNSL,CHNSOIL, 1CHNSLTMP,PRINHYD !WB Sediment Erosion routine information: Some equations and !WB calculations in the sediment subroutine are not placed in the !WB location that will allow optimal calculation efficiency. This is !WB recognized, and was done in order to ease understanding of the !WB methodology at the cost of computational efficiency. !WB END OF NEW VARIABLES FOR NEW DETACHMENT ROUTINES !RZ IRRIGATION VARIABLES COMMON /IRRIG/ IRRFLAG,IRRCROP,DEFLIMIT(20),STARTDAY(20), 1ENDDAY(20),FREQ(20),IRREFF(20),IRRATE(20),DURATION(20), 1IRRTARGET(30),LIMIT(20),IIRRI,IRRCYCLE(20),LASTIRR(20),SKIPFLAG, 1CROPNOIRR(20),IRRFLAG2(20) INTEGER SKIPFLAG,STARTDAY,ENDDAY,FREQ,LIMIT,CROPNOIRR DOUBLE PRECISION IRREFF,IRRATE,DURATION,IRRTARGET !RZ URBAN BMP VARIABLES DIMENSION CALLBMP(35000) INTEGER CALLBMP COMMON /BMP2/ PONDAREA(300),NRO(300),H2ODEPTH(300), 6ORAREA(300),WEIRVOL(300),ORVOL(300),ORTOP(300), 7MAXFLOW(300),SOLP(300),SOLNH4(300),SOLNO3(300), 8LOST(300),WLOST(300),ORBOT(300),TIPE(300), 9PIPEN(300),PIPED(300),PIPEL(300),RISD(300),PIPEAREA(300), 1RISH(300) INTEGER TIPE COMMON /BMP3/ POND(35000),STREAM(300),SUB(300) INTEGER POND,SUB COMMON /BMP4/ ENDNO3SI,MYSHADOW(35000),MAXPOND INTEGER MAXPOND DIMENSION A1DUMMY(3,300,24), A2DUMMY(35000), A3DUMMY(35000), 1A5DUMMY(3,300,2) INTEGER A1DUMMY, A2DUMMY COMMON /URBAN/ SEL2(35000,8),ROADWIDTH(20),URBSOIL(35000), 1PRTCLSSEL(35000,8),DETCAP(8),TRANSCAP(8),URB(35000),URBCR,ISRURB, 2STORM(35000),CURB(35000) INTEGER URBSOIL, URBAN, URB, URBCR, STORM, CURB INTEGER NOOFCHAN,HASOPENED,DIAGFLAG DIMENSION DIAGFLAG(35000) DIMENSION WID(30), CN(30), PP(14), TITLE(11) LOGICAL STRUC CHARACTER*4 C1, C2, C3, C4, C5, C6, PRI, UN, UNITS, PR, TEST CHARACTER*4 PP, TITLE, STRNAM, XDATE CHARACTER*2 IG, IELC, ITEMPC, ISTL CHARACTER*4 CDUMMY CHARACTER*2 A5DUMMY DATA C1,C2,C3,C4,C5,C6,PRI,UN/' RAI',' SI',' SO',' SU',' CH', 1' EL','PRIN','METR'/ DATA ISTL/'TI'/ DATA CDUMMY/' '/ C **** NOW, STORE THE NAMES OF THE STRUCTURAL PRACTICES. C DATA STRNAM/'PTO ','TERR','ACES','POND','S, L','AKES','G. W', 1'ATER','WAYS','FIEL','D BO','RDER'/ STRUC=.FALSE. C C ****** NUMBER OF STRUCTURAL PRACTICES PERMITTED. ARRAYS STRNAM AND C ****** NSTRUC MUST BE REDIMENSIONED IF ISTRUC IS MODIFIED. ALSO, THE C ****** ADDITIONAL STRUCTURE NAMES MUST BE ADDED TO THE DATA STATEMENT. C ISTRUC=4 !WB # of structural practices IT=0 !WB this appears to be a place holder for an array named PP OUTSID=0. !WB the number of cells flowing outside the watershed TMAX=0. !WB maximum time of the hydrograph TMIN=1.E+10 !WB minimum time of the hydrograph. It's big for a reason, that !WB is it is reset later to a smaller value. HASOPENED=0 !RZ this is a variable to control the reading of the bmp file; must be !RZ initialized to zero here, will be changed in bmp routine C C **** INPUT UNITS USED IN SIMULATION AND OUTPUT PRINT CONTROL. C READ (1,800) UNITS,PR !WB read the units and print flags C C **** NRZ C **** INPUT OUTPUT PRINT OPTIONS READ (1,801) NSBS !WB read the storm by storm output flag READ (1,801) (NPDAY(NZ),NZ=1,10) !WB read the additional days according to the above flag, up to 10 days 801 FORMAT (24X,10(1X,I7)) C C **** INPUT NUMBER OF RAINGAGES AND DATE OF EVENT. C READ (1,802) PRINHYD !WB FLAG TO INDICATE WHETHER TO PRINT HYDROGRAPHS. ADDED 14 AUG 1999 802 FORMAT (21X,I2) READ (1,810) TEST,NRG,XDATE !WB read the test (=' rai'), # of rain gages, not sure about xdate IF (NRG.GT.40) GO TO 540 IF (TEST.NE.C1) GO TO 580 !WB C1 equals ' rai' READ (1,1666) DAYBEG,YERBEG !WB read the beginning day and year of simulation READ (1,1667) SIMDUR !WB read the simulation duration DO 20 I=1,NRG READ(1,830) IG(I) !WB read from 1 to # of rain gages, the descriptor of each rain gage 20 CONTINUE C C ****** DEFINE DEFAULT SIMULATION REQUIREMENTS. MAXIMUM NUMBER OF C ****** HYDROGRAPH PRINT POINTS IS 101 (THIS IS THE NUMBER THAT WILL BE C ****** OUTPUT). NORMAL TIME STEP IS 60 SECONDS AND NORMAL TIME STEP C ****** FOR INFILTRATION IS 180 SECONDS. MAXIMUM EXPECTED RUNOFF RATE C ****** IS 2 INCHES (50.8 MM) PER HOUR. IF A SEGMENTED CURVE ERROR C ****** OCCURS DURING SIMULATION, INCREASE SF BY 50 PERCENT UNTIL THAT C ****** PROBLEM CEASES (IT MAY NOT BE THE ONLY PROBLEM, THOUGH). C ****** FOR WATERSHEDS WITH LARGE ELEMENTS (GREATER THAN 5 ACRES), C ****** MILD TOPOGRAPHY (LESS THAN 1 PERCENT AVERAGE SLOPES), OR C ****** MANY ELEMENTS (MORE THAN 1000), THE SIMULATION TIME STEP, DT, C ****** SHOULD BE INCREASED TO NO MORE THAN 300 SECONDS (5 MINUTES). C ****** SIMILARLY, FOR SMALL ELEMENTS (LESS THAN 1 ACRE), SEVERE C ****** TOPOGRAPHY, OR WATERSHEDS WITH ONLY A FEW ELEMENTS, THE C ****** SIMULATION TIME STEP SHOULD BE DECREASED TO 15 - 30 SECONDS. C C.... INPUT SIMULATION REQUIREMENTS C READ (1,810) TEST IF (TEST.NE.C2) GOTO 580 !WB C2 = ' si' READ (1,1030) NDT,DT,NFI,SF !WB # of lines of hydrograph print,sim time increment ,max # of !WB time increments b/t infil recalc's, segment factor IF (UNITS.EQ.UN) IT=7 !WB UN = 'metr' IF (PRI.EQ.PR) WRITE(2,630) DT,NFI,SF,PP(IT+1),PP(IT+2),NRG NFI=NFI/IFIX(SNGL(DT)) !WB NFI = same / DT as an integer (IFIX converts by truncating) C C **** INPUT INFILTRATION AND SOIL DATA. C READ (1,810) TEST IF (TEST.NE.C3) GO TO 580 !WB C3 = ' so' READ (1,780) ISR !WB ISR = # of soil types READ (1,780) ISRURB !RZ ISRURB= # OF URBAN SOIL TYPES, WHICH ARE THE FIRST SOILS IN DESCRIPTION SECTION IF (PRI.EQ.PR) WRITE (2,750) PP(IT+1),PP(IT+2),PP(IT+1) IF (ISR.GT.30) GO TO 530 ASMBAR=0. FPBAR=0. !WB I'm guessing that these are average values DO 60 I=1,ISR !WB do from i=1 to # of soil types !RZ if the urban flag is triggered, the first soil type is urban, therefore !RZ go to the urbanized subroutine to read the variables. This subroutine also !RZ calculates the needed variables from the next loop (DO 57); thus, the test in !RZ DO 57 skips to the end of the loop without going to the subroutine. IF (I.LE.ISRURB) THEN URBAN = 1 IDUMMY=0 DUMMY=0. CALL URBANIZED(URBAN,IDUMMY,IDUMMY,A1DUMMY,IDUMMY,IDUMMY,IDUMM 1Y,IDUMMY,IDUMMY,IDUMMY,CDUMMY,I,UNITS,A3DUMMY,A5DUMMY,DUMMY,DUMMY, 2DUMMY,DUMMY,DUMMY,IDUMMY,IDUMMY,A2DUMMY,A2DUMMY,CROP) GO TO 60 END IF READ (1,790) TP(I),FCAP(I),FC(I),A(I),DF(I),ASM(I) !WB read TP=porosity for soil type i, FCAP=field cap for soil i as a !WB fraction of pore space, FC=wilting point for soil it as a fraction !WB of pore space, A=ratio of sat hyd cond of the top layer and sat hyd !WB cond for underlying layer for soil i, DF=depth of soil horizon, !WB ASM=antecedent soil moisture as a fraction of pore space for soil i, C *** NRZ 9/12/94 C *** ADD LINE TO READ SATURATED HYDRAULIC CONDUCTIVITY FROM INPUT FILE READ (1,791) KOPT(I),SK(I) !WB I'm not really sure, but i'm guessing hydraulic conductivity? C *** NRZ 9/12/94 FCFRAC(I)=FCAP(I)*TP(I) !WB THE FIELD CAPACITY ON A VOLUME BASIS = FIELD CAP AS A FRACTION OF !WB PORE SPACE * FRACTIONAL PORE SPACE ASMBF(I)=ASM(I) !WB antecedent soil moisture as a fraction of pore space FCAP1(I)=FCAP(I) !WB field capacity as a fraction of pore space DF1(I)=DF(I) !WB depth of soil horizon SPER(I)=0. !WB steady state infiltration rate (mm/h) !RZ I believe this is wrong. I think SPER is a counter to determine how many cells !RZ have a particular soil type. SPER stands for Soil PERcent. READ(1,795) CL(I),SA(I),ST(I),OM(I),WCF(I),VFSPER(I) !WB CL = clay content of the soil, SA = sand content of the soil (%), !WB ST = silt content of the soil (%), OM = organic matter content (%) !WB WCF = weight of the coarse fragment (%),VFSPER = percent of very !WB fine sand in the soil. *PK REPRESENT SOIL PH C---- BD(I)=2.65*(1.-TP(I)) !WB bulk density g/cm3 C CC.....WATER TEMPERATURE ASSUMED TO BE 20 DEG.C. (68 DEG.F.)..... CC..........AT OTHER TEMPERATURES ADJUST VISCOS AND SWH2O.......... C AGRAV=32.174 !WB acceleration due to gravity VISCOS=0.0000108 !WB water viscosity SWH2O=62.32 !WB specific weight of water IF(UNITS.NE.UN) GO TO 58 !WB UN = 'METR' , so if its not metric, jump on down AGRAV=9.8066352 VISCOS=0.000001003352832 C SWH2O=9789.69088 SWH2O=999.1677535 58 CONTINUE 60 CONTINUE C DO 57 I=1,ISR !RZ URBAN: if the soil type is urban, skip all these calculations. They have to do with !RZ soil interactions and are not present for urban 'soil' types. IF(I.LE.ISRURB) GO TO 57 !RZ ************************************************* *ADDING THE CRUST THICKNESS ASSUMED TO BE 0.005M ZC(I)=0.5 ************************************************* ***************************** ***POROSITY *************** PHI(I)=TP(I) !WB porosity = porosity ****VOLUME OF COARSE FRAGMENT (>2MM) VCF(I)=100.*(WCF(I)/2.65)/(100.-(WCF(I)/BD(I))+(WCF(I)/2.65)) * WHERE WCF IS THE WEIGHT OF COARSE FRAGMENT (%) ****CORRECTION FACTOR FOR COARSE FRAGMENT CFC(I)=1.0-(VCF(I)/100.0) ****CATION EXCHANGE CAPACITY/%CLAY CEC(I)=(0.0059*CL(I)+0.041)/(.6*CL(I)) IF(CEC(I).LT.0.15) CEC(I)=0.15 ****CORRECTION FOR ENTRAPPED AIR EAC(I)=1.0-(3.8+0.00019*CL(I)**2.-0.0337*SA(I)+0.126*CEC(I) & *CL(I)+OM(I)*(SA(I)/200.)**2.)/100. ************************** ****EFFECTIVE POROSITY PHIC(I)=PHI(I)*CFC(I)*EAC(I) ************************** **************************** ****CAPILLARY FRONT POTENTIAL ***************************** XF(I)=6.531-7.33*PHIC(I)+.001583*CL(I)**2.0+3.81*PHIC(I)**2.0 & -.0498*SA(I)*PHIC(I)-.000799*SA(I)**2.0*PHIC(I) &-.0000140*SA(I)**2.0*CL(I)-.00348*CL(I)**2.0*PHIC(I) & +.00034*CL(I)*SA(I)+.0016*CL(I)**2.0*PHIC(I)**2.0 & +.00161*SA(I)**2.0*PHIC(I)**2.0 ************************ PSIF(I)=DEXP(XF(I)) *************************************** !WB PSIF = cap potential at the infil wetting front (mm) *CONVERTING PSIF TO MM PSIF(I)=10.*PSIF(I) ************************ ******CONSTANT C USED TO COMPUTE THE SATURATED HYDRAULIC CONDUCTIVITY CBF(I)=-0.17+0.181*CL(I)-0.00000069*SA(I)**2.0*CL(I)**2.0 & -.00000041*SA(I)**2.0*ST(I)**2.0+0.000118*SA(I)**2.0*BD(I)**2. & +0.00069*CL(I)**2.0*BD(I)**2.0+0.000049*SA(I)**2.0*CL(I) & -0.000085*ST(I)*CL(I)**2.0 ****RESIDUAL SOIL WATER THETAR(I)=(0.2+0.1*OM(I)+0.25*CL(I)*CEC(I)**0.45)*(BD(I)/100) & *EAC(I)*CFC(I) asmbf(i)=asmbf(i)-(thetar(i)/tp(i)) RESWAT(I)=THETAR(I)/TP(I) **** * UPPER STAGE OF SOIL EVAPORATION (MM DAY ** -0.5) ** ESU(I)= 9.*((4.165+0.02456*SA(I)-0.01703*CL(I)-0.0004*SA(I) ** 1 *SA(I))-3.)**0.42 ESU(I)=9.*(3.5-3.)**0.42 *COMPUTE THE MAXIMUM EVAPORATIVE DEPTH EDX(I)=90.-0.77*CL(I)+0.006*SA(I)*SA(I) ************************************ ****SATURATED HYDRAULIC CONDUCTIVITY KS(I)=((PHIC(I)-THETAR(I))**3.0/(1-PHIC(I))**2.0) & *(BD(I)/THETAR(I))**2.0*0.0002*CBF(I)**2.0 ************************************ ****MACROPOROSITY FACTOR Z(I)=DEXP(0.96-.032*SA(I)+.04*CL(I)-0.032*BD(I)) IF(Z(I).LE.0.4) Z(I)=0.4 * SEE WEPP MANUAL ****CRUST FACTOR ZC(I)=1. SCF(I)=0.0099+.0721*ZC(I)+0.0000068*SA(I)**2.+.0000212*SA(I) & **2.0*ZC(I)+.0003151*SA(I)*ZC(I)**2.0 ****DEPTH TO WETTING FRONT *** DEPTH TO WETTING FRONT MUST BE GREATER THAN CRUST DEPTH (1CM) LF(I)=14.7-(0.0015*SA(I)**2.)-0.3*CL(I)*BD(I) IF(LF(I).LE.ZC(I)) LF(I)=ZC(I) ****CORRECTION FACTOR FOR PARTIAL SATURATION OF THE SUBCRUST SOIL CS(I)=0.74+0.0019*SA(I) ****CRUST REDUCTION FACTOR CRC(I)=LF(I)/((LF(I)-ZC(I))/CS(I)+ZC(I)/SCF(I)) *CONVERTING KS FROM CM/HR TO MM/HR KS(I)=KS(I)*10. C *** NRZ 9/12/94 C *** ASSIGN USER ENTERED VALUE OF SATURATED HYDRAULIC CONDUCTIVITY IF (KOPT(I).EQ.1) KS(I) = SK(I) !WB KOPT must be a flag for the K option, C *** NRZ 9/12/94 LF(I)=LF(I)*10. * this is the depth of the first soil layer * DF(I)= 250. *COMPUTING PARTITION FACTOR FOR DISSOLVED AND ADSORBED AMMONIUM PKDA(I)=1.34+0.083*CL(I) *COMPUTING PARTITION COEFFICIENT FOR PHOSPHORUS PKDP(I)=100.+2.5*CL(I) * PKDP(I)=5.1+2.2*CL(I)+26.4*(PK(I)-6.)*(PK(I)-6.) * WRITE(6,*) PK(I),PKDP(I) PSP(I)=0.46-0.0916*DLOG(CL(I)) IF(PSP(I).LT.0.05)PSP(I)=0.05 IF(PSP(I).GT.0.75) PSP(I)=0.75 !WB phosphorus sorption coefficient C---- IF (PRI.EQ.PR) WRITE (2,640) I,TP(I),FCAP(I),FC(I),KS(I),DF(I) 1,ASM(I) !WB I = counter to # of soil types, TP = porosity for soil type i, !WB FCAP = field cap, FC = wilting point, KS = sat hydr cond, DF = !WB depth of soil horizon, ASM = antecedent soil moisture 57 CONTINUE C C .... ADDITIONAL CALCULATIONS FOR EXTENDED SEDIMENT MODEL C WRITE(2,1040) READ(1,1050)NPART,NWASH !WB NPART = # of particle size classes, NWASH = # of washload particles WRITE(2,1060)NPART,NWASH NWASH1=NWASH+1 IF(NWASH.EQ.NPART) NWASH1=1 VISCOS=1./VISCOS !WB VISCOS = kinematic viscosity of water (m2/s) READ(1,1070)(DIAMM(IC),SG(IC),FV(IC),IC=1,NPART) !WB DIAMM = particle diameter (MM), SG = spec grav, FV = fall velocity DO 70 IC=1,NPART IF(UNITS.EQ.UN) GO TO 61 DIA(IC)=DIAMM(IC)*.0032808399 !WB particle diameter (m) GO TO 62 61 DIA(IC)=DIAMM(IC)*0.001 62 IF(FV(IC).LE.0.00000001) GO TO 63 GO TO 70 C CC.........CALCULATION OF PARTICLE FALL VELOCITIES.......... C 63 FV(IC)=AGRAV*(SG(IC)-1.)*VISCOS*DIA(IC)**2/18. X1=DIA(IC)*VISCOS REYN=FV(IC)*X1 !WB particle reynold's # IF(REYN.LE.0.1) GO TO 70 X2=DSQRT(4.*AGRAV*(SG(IC)-1.)*DIA(IC)/3.) DO 69 I=1,10 CD=24./REYN+3./DSQRT(REYN)+.34 !WB CD = drag coeff. used in determining particle fall velocity FV(IC)=X2/DSQRT(CD) REYN=FV(IC)*X1 69 CONTINUE 70 CONTINUE C CC.........CALCULATION OF EQUIVALENT SAND DIAMETERS......... C DO 78 IC=1,NPART IF(SG(IC).GT.2.645) GO TO 77 !WB if spec gravity of particle size gt 2.645 X4=FV(IC)*VISCOS !WB X4 = fall velocity * kin viscos of water DS=DSQRT(10.90909091*FV(IC)/(AGRAV*VISCOS)) !WB sand diameter? because its not the rate of sed inflow REYN=X4*DS !WB reynolds # = X4 * sand diameter IF(REYN.LE.0.1) GO TO 76 X3=FV(IC)**2/(AGRAV*2.2) DO 75 II=1,20 DS=X3*(24./REYN+3./DSQRT(REYN)+.34) REYN=X4*DS 75 CONTINUE 76 EQSDIA(IC)=DS !WB equivalent sand diameter of particle i (m) GO TO 78 77 EQSDIA(IC)=DIA(IC) 78 CONTINUE X3=304.8 IF(UNITS.EQ.UN) X3=1000. DO 79 IC=1,NPART 79 EDMM(IC)=EQSDIA(IC)*X3 WRITE(2,1080)PP(IT+4) WRITE(2,1090)(IC,DIAMM(IC),EDMM(IC),SG(IC),FV(IC),IC=1,NPART) WRITE(2,1100) DO 85 J=1,ISR READ(1,1110)(F(J,I),I=1,NPART) !WB fraction of particles of type i in original soil 85 WRITE(2,1120)J,(F(J,I),I=1,NPART) ********************************************************************** * INPUT SPECIFIC SURFACE AREA FOR PHOSPHORUS COMPONENT * SPECIFIC SURFACE AREA MUST BE IN M^2/G WRITE(2,*)'SPECIFIC AREA FOR DIFFERENT PARTICLE SIZE' DO 86 J=1,ISR IF (URBSOIL(J).EQ.1) THEN WRITE(2,1111) 0.,(SSA(J,I),I=1,NPART) GO TO 86 END IF READ(1,1111) SSAT(J),(SSA(J,I),I=1,NPART) !WB SSA = spec surf area for part class i for soil type j, SSAT = total !WB SSA for soil type j WRITE(2,1111) SSAT(J),(SSA(J,I),I=1,NPART) 86 CONTINUE DO 81 J=1,ISR SASA=0. !WB SASA = unknown; rz this is the sum of surface area for each particle size class; !RZ assuming you determine your fraction of soil in each type correctly (i.e., does !RZ not add up to something other than 1), this will be the same as SSAT. IF (URBSOIL(J).EQ.1) THEN GO TO 81 END IF DO 88 I=1,NPART SSA(J,I)=SSA(J,I)*F(J,I) SASA=SASA+SSA(J,I) 88 CONTINUE DO 82 I=1,NPART SSA(J,I)=SSA(J,I)*SSAT(J)/SASA 82 CONTINUE 81 CONTINUE ********************************************************************** C C **** NRZ 9/12/94 C **** MODIFY INPUT LINE TO INCLUDE FERTILIZER FILE FLAG C **** INPUT DRAINAGE AND GROUNDWATER CONSTANTS. C C READ (1,980) NEXP,DC,GRF READ (1,980) NEXP,DC,GRF,IFERT,IIRRI !WB NEXP = ? (rwz:called drainage exponent; see Huggins&Monke 1966 p44) !RWZ nexp appears to be a relic from the original version of answers, and !RWZ is no longer used in the current model, !WB DC = tile drainage coefficient, GRF = fractional !WB rate of baseflow release, IFERT = fert app flag, IIRRI = irrigation appl. flag IF (PRI.EQ.PR) WRITE (2,990) NEXP,DC,PP(IT+1),GRF IF (IFERT.EQ.1) OPEN (9,FILE='FERTILIZER.INP',STATUS='OLD') IF (IIRRI.EQ.1) OPEN (378,FILE='IRRIGATION.INP',STATUS='OLD') C **** NRZ 9/12/94 ** NRZ (8/29/94) ** ADDED IMPOUNDMENT INPUT STATEMENT C C **** INPUT IMPOUNDMENT DATA READ (1,981) NIMP WRITE(2,*) 'THE NUMBER OF IMPOUNDMENTS IS ',NIMP IF (NIMP.GT.0) THEN READ(1,*) READ(1,*) ENDIF DO 12000 NCHC=1,NIMP READ (1,982) NCH,BASE(NCH),WIDTH(NCH),SLOPE(NCH),ORIF(NCH), & MAXHGT(NCH),CI(NCH),FI(NCH),AFWEV !WB See the input variable guide for a description of this subroutine. 12000 CONTINUE ** NRZ (8/29/94) C C **** INPUT CROP AND SURFACE ROUGHNESS DATA. C READ (1,810) TEST IF (TEST.NE.C4) GO TO 580 !WB C4 = ' SU' READ (1,940) ICR WRITE(2,*) 'THE NUMBER OF CROPS IS',ICR !rz URBAN IDEA - INSERT A READ HERE TO DETERMINE THE NUMBER OF URBAN !RZ CROP TYPES; THEN FOR THOSE FIRST CROP TYPES IN THE 87 LOOP JUMP TO !RZ THE URBAN SUBROUTINE READ (1,940) URBCR !RZ read the number of urban crops WRITE (2,*) 'THE NUMBER OF URBAN CROPS IS', URBCR IF (PRI.EQ.PR) WRITE (2,950) PP(IT+1),PP(IT+1),PP(IT+1) IF (ICR.GT.20) GO TO 550 DO 87 I=1,ICR CBAR(I)=0. !WB percent of watershed in crop i !RZ IF THERE IS AN URBAN CROP, IT HAPPENS FIRST; DO A SEPARATE READ IN THE URBAN SUBROUTINE !RZ FOR THE URBAN CROP IF (I.LE.URBCR) THEN URBAN = 2 IDUMMY=0 DUMMY=0. CALL URBANIZED(URBAN,IDUMMY,IDUMMY,A1DUMMY,IDUMMY,IDUMMY,IDUMM 1Y,IDUMMY,IDUMMY,ISR,PR,I,CDUMMY,A3DUMMY,A5DUMMY,DUMMY,DUMMY,DUMMY, 2DUMMY,DUMMY,IDUMMY,IDUMMY,A2DUMMY,A2DUMMY,CROP) RN(I)=MNTOT(I) !RZ WB RN(I) = manning's n for surface type I !RZ SET HERE BECAUSE RN IS NOT A COMMON VARIABLE AND IS NEEDED LATER GO TO 87 END IF READ (1,620) CROP(I,1),CROP(I,2),PIT(1,I),PER(I),ROUGH(I),HU(I), 1DIRM(I) !WB CROP(I,1),CROP(I,2) = alphanumeric name of crop i !WB PIT(1,I) = interception storage for cover for surface type i (mm) !WB PER(I) = fraction of element area covered by foliage for surface type i !WB ROUGH(I) = surface depth-storage parameter for surface i !WB HU(I) = maximum height differential on soil surface (mm) !WB DIRM(I) = maximum physical retention depth for cropping practice i DIRM2(I)=DIRM(I) !WB max physical ret depth for crop practice i = same READ(1,623) AC(I),AO(I),BC(I),BO(I),INRCOVI(I),INRCOVF(I), 1LIVEROOT(I),DDROOTI(I),DDROOTF(I) !WB AC(I) = canopy area (%) !WB AO(I) = area outside canopy (%) !WB BC(I) = bare area under canopy (%) !WB BO(I) = bare area outside canopy (%) !WB INRCOVI(I) = INTERRILL AREA COVERED BY GROUND COVER AT BEG OF SEASON !WB INRCOVF(I)=INTERRILL AREA COVERED BY GROUND COVER AT END OF SEASON !WB LIVEROOT(I)=MASS OF LIVE ROOTS IN THE 0 TO 0.15 M OF THE SOIL SURFACE !WB IN KG/M^2 !WB DDROOTI(I) = MASS OF DEAD ROOTS AT THE BEG OF THE COVER PERIOD IN THE !WB 0 TO 0.15 M OF THE SOIL SURFACE IN KG/M^2 !WB DDROOTF(I) = MASS OF DEAD ROOTS AT THE END OF THE COVER PERIOD IN THE !WB 0 TO 0.15 M OF THE SOIL SURFACE. IF (DDROOTI(I).LT.DDROOTF(I)) THEN WRITE (*,1962) DDROOTI(I),DDROOTF(I) PAUSE STOP ENDIF INRCOVI(I)=INRCOVI(I)/100. INRCOVF(I)=INRCOVF(I)/100. READ(1,624) (LAI(I,I111),I111=1,11) !WB leaf area index READ(1,625) DATPLA(I),DATHAR(I),CP1(I),CP2(I),DMY(I),YP(I) & ,ROTMAX(I),RLAIMX(I) !WB DATPLA(I) = planting date !WB DATHAR(I) = harvest date !WB CP1(I) = exponent for nitrogen content !WB CP2(I) = exponent for nitrogen content !WB DMY(I) = dry matter ratio !WB YP(I) = yield potential (kg/ha) !WB ROTMAX(I) = maximum rooting depth for crop i (mm) !WB RLAIMX(I) = maximum lai !WB ***** READ IN THE PARAMETERS FOR THE NEW SED ROUTINE ********* READ(1,626) RANROU(I),BR(I),MAXPLHGT(I),GROWFACT(I),RILLSPC(I), 1MNSOIL(I),MNTOT(I),NOTILL(I),NOEROS(I) !WB RANROU=RANDOM ROUGHNESS OF THE SOIL SURFACE(MM), BR=BURIED RESIDUE !WB W/IN 0 TO 0.15 M OF THE SOIL SURFACE (KG/HA), MAXPLHGT=MAXIMUM !WB PLANT CANOPY HEIGHT (M), GROWFACT=FRACTION OF GROWTH PERIOD !WB REQUIRED FOR THIS CROP TO REACH MATURITY, RILLSPC=RILL SPACING !WB (M OR M/RILL WHICH SAYS M B/T RILLS), MNSOIL=MANNING'S N !WB FRICTION FACTOR FOR THE BARE SOIL, MNTOT=MANNING'S N FRICTION !WB FACTOR FOR THE SURFACE WITH COVER. NOTILL=A TILLAGE FLAG THAT !WB INDICATES THE CROP COVER IS A NO-TILL CROP. THIS AFFECTS THE !WB RILL WIDTH CALCULATION. NOEROS=A FLAG INDICATING THAT A CROP !WB IS A NON-ERODIBLE PRACTICE (I.E.-POND, COMMERCE) RN(I)=MNTOT(I) !WB RN(I) = manning's n for surface type 1, I MOVED THIS FROM WHERE !WB IT WAS READ ORIGINALLY DUE TO SOME LAST MINUTE CHANGES. RANROUM(I)=RANROU(I)/1000 !WB CONVERT RANDOM ROUGHNESS TO M FROM MM DO K=1,4 READ (1,629) ATMDEP(I,K), TKNDEP(I,K), AMNDEP(I,K), SEPDEP(I,K), 1NO3ZDEP(I,K), WATNHDEP(I,K), SOLUBPDEP(I,K), TSSDEP(I,K) END DO !WB ERROR CHECKS IF (MNSOIL(I).GT.MNTOT(I)) THEN WRITE (2,1950) MNSOIL(I),MNTOT(I),I WRITE (*,1950) MNSOIL(I),MNTOT(I),I STOP ENDIF IF (NOTILL(I).NE.0) THEN IF (NOTILL(I).NE.1) THEN WRITE (*,1952) WRITE (2,1952) PAUSE STOP ENDIF ENDIF IF (NOEROS(I).NE.0) THEN IF (NOEROS(I).NE.1) THEN WRITE (*,1954) WRITE (2,1954) PAUSE STOP ENDIF ENDIF IF (BR(I).GT.1) THEN WRITE (*,1956) WRITE (2,1956) PAUSE ENDIF !WB ERROR CHECKS *********************************************************************** * COMPUTE A EFFECTIVE HYDRAULIC CONDUCTIVITY FOR EACH SOIL * CROP COMBINATION) ****CANOPY FACTOR CF(I)=1.+AC(I)/(AC(I)+AO(I)) !WB CF = 1+canopy area / (canopy area + area outside of canopy) DO 84 KKK=1,ISR ************************************ ****EFFECTIVE HYDRAULIC CONDUCTIVITY ** SEARCHING FOR THE CORRECT HYDRAULIC CONDUCTIVITY ************************************************************* *********************************************************** KE(KKK,I)= KS(KKK)* & ( CF(I)*(AC(I)/100.) & *(BC(I)*CRC(KKK)/AC(I)+Z(KKK)*(1-BC(I)/AC(I))) & +(AO(I)/100.) & *(BO(I)*CRC(KKK)/AO(I)+Z(KKK)*(1-BO(I)/AO(I)))) ***************************************************************** 84 CONTINUE IF (ROUGH(I).GT.1.0.OR.ROUGH(I).LE.0.) GO TO 590 IF (PRI.EQ.PR) WRITE (2,960) I,CROP(I,1),CROP(I,2),PIT(1,I),PER(I) 1,ROUGH(I),HU(I),DIRM(I) 87 CONTINUE !WB ******* PRINT SECTION FOR NEW SEDIMENT VARIABLES ******* DO I=1,ICR IF (PRI.EQ.PR) THEN IF (I.EQ.1) WRITE (2,975) WRITE (2,976) I,RANROU(I),BR(I),MAXPLHGT(I),GROWFACT(I) 1,RILLSPC(I) END IF END DO DO I=1,ICR IF (PRI.EQ.PR) THEN IF (I.EQ.1) WRITE (2,977) WRITE (2,978) I,MNSOIL(I),MNTOT(I),NOTILL(I),NOEROS(I) ENDIF END DO DO I=1,ICR IF (PRI.EQ.PR) THEN IF (I.EQ.1) WRITE (2,1958) WRITE (2,1960) I,INRCOVI(I),INRCOVF(I),LIVEROOT(I),DDROOTI(I), 1DDROOTF(I) ENDIF END DO WRITE (2,*) !WB ***** END OF PRINT SECTION FOR NEW SEDIMENT VARIABLES ***** C **** RWC C INPUT ROTATION DESCRIPTION READ(1,940) IROT1 DO 89 I=1,IROT1 WRITE(2,*) 'READING IN THE ROTATION PARAMETERS FOR',I C **** NRZ 7/20/95 C **** MODIFIED ROTATION INPUT TO ALLOW 8 ADDITIONAL END DATES C READ(1,1800) IROT(I,1),(IROT(I,I1111),I1111=2,41) !TMN MODIFIED ROTATION INPUT TO ALLOW FOR UP TO 644 END DATES !TMN THIS WILL GIVE UP TO 107 SIMULATION YEARS WITH 3 END DATES PER YEAR ! READ(1,1800) IROT(I,1),(IROT(I,I1111),I1111=2,57) READ(1,1800) IROT(I,1),(IROT(I,I1111),I1111=2,644) 89 CONTINUE C C **** INPUT CHANNEL DATA. C READ (1,810) TEST IF (TEST.EQ.C6) GO TO 80 !WB ' EL' !WB if there are no channel elements, then they are overland !WB elements, jump down to 80 to read those IF (TEST.NE.C5) GO TO 580 !WB ' CH', if the flag doesn't equal el or ch, then something !WB is wrong, so jump down and stop the program C **** NRZ 9/11/94 C **** ADD INPUT FOR NUMBER OF CHANNEL NETWORKS READ (1,920) NCHAN C **** NRZ 9/11/94 READ (1,920) M !WB M = # of types of channels NOOFCHAN=M IF (M.GT.30) GO TO 510 !WB if there are more than 10 types of channels, then jump down !WB and stop the program !!!!!shouldn't there be only 9 channel !WB types? READ (1,760) (WID(I),MNCS(I),CN(I),IMPERM(I),ARMOUR(I),I=1,M) !WB WID = width of channel type, CN = manning's n for channel type i !WB MNCS=MANNING'S N FRICTION FACTOR FOR BARE SOIL FOR THE CHANNEL, !WB MNCT=MANNING'S N FF FOR SOIL+VEGETATION IN CHANNEL, IMPERM= !WB DEPTH TO IMPERMEABLE LAYER IN THE CHANNEL, ARMOUR = FRACTION !WB OF CHANNEL SOIL THAT IS UNERODIBLE, OR EROSION RESISTANT DO I=1,M MNCT(I)=CN(I) !WB SET THE MANNING'S N CHANNEL SOIL + VEG VARIABLE EQUAL TO CN (SAME) ENDDO IF (MNCS(I).GT.MNCT(I)) THEN WRITE (*,1950) MNCS(I),MNCT(I),'CHAN ',I STOP ENDIF IF (PRI.EQ.PR) WRITE (2,650) PP(IT+4),(I,WID(I),MNCS(I), 1MNCT(I),IMPERM(I),ARMOUR(I),I=1,M) C C **** INPUT OUTFLOW ELEMENT POSITION. C READ (1,820) TEST,TITLE !WB why read test and title of the farm !RWZ test to determine you're in the right place; title !RWZ reads the title "baseline sensitivity analysis" for the output file IF (TEST.NE.C6) GO TO 580 !WB C6 = ' EL' C **** NRZ 9/11/94 C **** OPEN A SCRATCH OUTPUT FILE FOR EACH CHANNEL OUTLET AND THE "LEAKY" C **** CELLS DO 91 NCH=1,NCHAN+1 NUNIT=10+NCH IF (NCH.LE.NCHAN) THEN WRITE(OUTFIL(NCH),301) 'CHANNEL',NCH,'.OUT' 301 FORMAT (A7,I1,A4) ELSE WRITE(OUTFIL(NCH),302) 'LEAKYCELL.OUT' 302 FORMAT (A13) ENDIF OPEN (NUNIT,FILE=OUTFIL(NCH)) !WB I feel as though this should be above the if then loop, but !WB this seems to work. Something to look into. I commented this !WB line out and the program wrote the proper file anyway. !RZ No, the IF THEN sets the name of the output file; then the open !RZ statement actually opens a file with that name. Just like is done !RZ in the ascii builder. 91 CONTINUE C **** MODIFY INPUT LINE TO ACCEPT MULTIPLE OUTLETS C 80 READ (1,610) DX,NIOUT,NJOUT C *** NRZ C *** The length of the side of each square element is DX 80 READ (1,609) DX READ (1,610) (NIOUT(NCH),NJOUT(NCH),NCELLS(NCH),NCH=1,NCHAN) !WB NIOUT = row # of catchment outflow element, NJOUT = column # !WB of outlet cell for channel network i, NCELLS = # of cells in !WB channel network i (entered as input) C **** NRZ 9/11/94 C C **** EVALUATE CONSTANTS FOR USE WITH METRIC OR ENGLISH UNITS. C **** METRIC UNITS. C DX2=DX*DX C *** NRZ C *** The area of each cell (in ha) is computed here AREA2=DX2/1.E+4 !WB area2 is supposed to be element or channel area, but instead it !WB looks like area in ha CU1=DX2/1.E+3 !WB conversion from mm to m3 CU2=DT/DX2*500. !WB conversion for twice m3?, looks like time increment / (cell !WB size in m2 * 500) CU=DX2/3.6E+6 !WB conv from mm/h to m3/s? = cell area in m2 / 3.6E6 CONST=DX/(2./DT*DX2)**1.6667 !WB flow depth units conversion factor = cell width / (2./cell !WB width * cell area in m2) ^1.6667 IF (UNITS.EQ.UN) GO TO 90 !WB jump over the next section if the units are metric C C **** CONVERT TO ENGLISH UNITS. C CU1=CU1/.012 CU=CU/.012 CU2=CU2*.012 CONST=1.486*CONST AREA2=AREA2/4.3560 C C **** INPUT INDIVIDUAL ELEMENT TOPOGRAPHICAL DATA. C * CHANGING ORIGINAL VALUE OF NPAR AND NPAR2 FROM 13 & 11 TO 20,18 90 NPAR=26 NPAR2=24 !WB NPAR and NPAR2 are counters for the # of parameters, and are !WB used for data manipulation C C **** CHANGE DIMENSION STATEMENT BELOW IF JMAX IS CHANGED. C JMAX=300 !WB max # of columns NMAX=35000 !WB max # of cells, overland flow + channel segments N=0 !WB probably a counter reset II=0 !WB II is a counter / place holder SCMIN=9. !WB minimum slope value, probably in channels SCMAX=0. !WB max value of slope, probably in channels SCBAR=0. !WB average value of slope, probably in channels SMIN=9. !WB min elemental and channel slope in watershed SMAX=0. !WB final accum sed loss from catchment (kg)? maybe max slope SBAR=0. !WB average catchment slope TBAR=0. !WB percent of elements tiled DO 100 J=1,JMAX 100 IEL(3,J,3)=0 !WB make sure you reset the last element flag of element counter flag !WB to 0 for all elements C C **** INPUT FIRST ROW OF ELEMENTAL DATA. C * ADDED PHOSPHORUS INPUT ITEMP(12,13) READ (1,680) (ITEMP(K),K=1,7),(ITEMPC(L),L=1,2),(ITEMP(K),K=8,16) READ (1,681) (ITEMP(K),K=17,24) !RZ URBAN: add 21, URB(I) flag !WB ITEMP(1) = element # !WB ITEMP(2) = column # of last watershed element in the row !WB ITEMP(3) = 9 in this column indicates last element in list !WB ITEMP(4) = slope steepness in tenths of a percent (2.9% = 29) !WB ITEMP(5) = direction of steepest slope, in c!WB degrees from r-horizon !WB ITEMP(6) = channel network designator AND SOIL TYPE !WB ITEMP(7) = I1 = rotation # !WB ITEMPC(1) = rain gauge designator !WB ITEMPC(2) = tile drainage designator !WB ITEMP(8) = SS(I) = channel slope !WB ITEMP(9) = PRACT = # of structural practice type (BMP practice?) !WB ITEMP(10) = TRAP = trapping efficiency of ponds / bmps !WB ITEMP(11) = CHAN = channel # perhaps? !WB ITEMP(12) = SORGP = soil organic P (kg/ha) !WB ITEMP(13) = EDI = effective depth of interaction !WB ITEMP(14) = PMINP = active mineral P (kg/ha) !WB ITEMP(15) = SOILP = stable soil P (kg/ha) !WB ITEMP(16) = PLAB = labile P (kg/ha) !WB ITEMP(17) = POTMIN = potentially mineralizable soil N (kg/ha) !WB ITEMP(18) = AMON = total NH4 present in soil (kg/ha) !WB ITEMP(19) = SOILN = stable soil organic N (kg/ha) !WB ITEMP(20) = SZNO3 = nitrate present in soil (kg/ha) !RZ ITEMP(21) = URB = urban cell flag !RZ ITEMP(22) = STORM = stormwater drain flag !RZ ITEMP(23) = DRDEST = stormwater drain destination cell !RZ ITEMP(24) = CURB = curb flag C **** NRZ 9/11/94 C **** MODIFIED CALL FOR MULTIPLE OUTLETS !WB the input cell data is read in to the itemp arrays, and then !WB you jump down to the subroutine relem and roll 2 into 1 and !WB then 3 into 2. Then, in relem, you move the itemp array !WB elements into the third row. Then you are returned. You go !WB through this twice because the first time you roll the data !WB into lines 2 and 1 when they are originally empty. Then you !WB go through again, roll 2 into 1, 3 into 2 and then itemp into !WB line 3. In relem, you read all the column elements in a row !WB before being returned to the xdata subroutine. !WB Then you can do calculations (2&3 have data in them). !RZ ACTUALLY, 1 HAS PREVIOUS ROW DATA, 2 HAS CURRENT ROW DATA, AND !RZ 3 HAS NEXT ROW DATA !WB The elements of IEL !WB are put in as (i,j,k) where i = row #, j = column #, !WB k = parameter value, except for 3 (i,j,3) which is reset !WB to an element 3 counter, and (i,1,2) which is set to !WB the column # of the last element in that row CALL RELEM (IEL,ITEMP,N,ISR,ICR,NMAX,JMAX,NPAR,IELC,ITEMPC, 1NPAR2) C C **** PUT WATERSHED ELEMENTAL DATA INTO SINGLE DIMENSIONED ARRAYS. C C **** MODIFIED CALL FOR MULTIPLE OUTLETS 110 CALL RELEM (IEL,ITEMP,N,ISR,ICR,NMAX,JMAX,NPAR,IELC,ITEMPC, 1NPAR2) C 110 CALL RELEM (IEL,ITEMP,N,MOUT,NIOUT,NJOUT,ISR,ICR,NMAX,JMAX,NPAR, C 1IELC,ITEMPC,NPAR2) C **** NRZ 9/11/94 JS=IEL(2,1,2) !WB column # for last column on current element row which is set in !WB the relem subroutine. !WB************************************************* !WB beginning of do loop for the current row's calculations !WB************************************************* DO 270 J=1,JS !WB do this for the # of columns? JM1=J-1 I=IEL(2,J,3) !WB I is reset to an element # counter (it holds the # counter) !WB in the relem subroutine. Also, mout(nch) is set equal to niout !WB and njout in the relem subroutine. IF (I.EQ.0) GO TO 270 !WB if the element counter = 0, jump out of this loop, but I'm !WB not sure when this would be true. SL(I)=DBLE(IEL(2,J,4))/1000. !WB overland element slope IF (SL(I).LT.SMIN) SMIN=SL(I) IF (SL(I).GT.SMAX) SMAX=SL(I) SBAR=SBAR+SL(I) C **** NRZ 9/5/94 C **** COMPUTE CHANNEL NETWORK DESIGNATOR AND CHANNEL WIDTH NUMBER C **** FROM 5-DIGIT NUMBER IEL(2,J,6) CHNUM(I)=IEL(2,J,6)/1000000 !WB chnum is the channel # designator CHAN(I)=MOD(IEL(2,J,6),1000000)/10000 !WB chan(I) = (IEL(2,J,6)-int(IEL(2,J,6)/1000000)*1000000)/10000 !WB so this is the 3rd number in decimal form of the channel # !WB designator (for ex: CHAN(I) of 10201 is 2.01), CHAN(I) is !WB the width designator for the channel (it's a type 1 or 2, etc) IF (CHAN(I).GT.0) THEN CHNSL(I)=(MOD(MOD(IEL(2,J,6),1000000),10000))/100 !WB CHNSL(I)= SOIL TYPE # OF CHANNEL CELL IF (CHNSL(I).GT.ISR) THEN WRITE (2,865) CHNSL(I),I,ISR WRITE (*,865) CHNSL(I),I,ISR PAUSE STOP ENDIF ENDIF C **** NRZ 9/5/94 IF (CHAN(I).GT.30) WRITE (2,1020) CHAN(I),I !WB if the channel # is greater than 10, then write it !WB I feel like this should be an error statement, or should !WB do something aside from simply writing the cell width & # SS(I)=DBLE(IEL(2,J,8))/1000. !WB SS is channel slope / 1000 ******************************************************************** * PUT PHOSPHORUS AND NITROGEN INPUT VALUE INTO DIMENSIONED ARRAYS * P0SOIL=INITIAL PHOSPHORUS CONTENT OF SOIL * EDI EFFECTIVE DEPTH OF INTERACTION * INPUT ARE DONE IN KG/HA * CONVERT EVERYTHING TO KG ******************************************************************** CONFAY=DX*DX/10000. !WB confay = (area in ha) SORGP(I)=IEL(2,J,12) !WB SORGP = soil organic P (kg/ha) SORGP(I)=SORGP(I)*CONFAY EDI(I)=IEL(2,J,13) !WB ITEMP(13) = EDI = effective depth of interaction PMINP(I)=IEL(2,J,14) !WB ITEMP(14) = PMINP = active mineral P (kg/ha) PMINP(I)=PMINP(I)*CONFAY SOILP(I)=IEL(2,J,15) !WB ITEMP(15) = SOILP = stable soil P (kg/ha) SOILP(I)=SOILP(I)*CONFAY PLAB(I)=IEL(2,J,16) !WB ITEMP(16) = PLAB = labile P (kg/ha) PLAB(I)=PLAB(I)*CONFAY POTMIN(I)=IEL(2,J,17) !WB ITEMP(17) = POTMIN = potentially mineralizable soil N (kg/ha) POTMIN(I)=POTMIN(I)*CONFAY AMON(I)=IEL(2,J,18) !WB ITEMP(18) = AMON = total NH4 present in soil (kg/ha) AMON(I)=AMON(I)*CONFAY SOILN(I)=IEL(2,J,19) !WB ITEMP(19) = SOILN = stable soil organic N (kg/ha) SOILN(I)=SOILN(I)*CONFAY SZNO3(I)=IEL(2,J,20) !WB ITEMP(20) = SZNO3 = nitrate present in soil (kg/ha) SZNO3(I)=SZNO3(I)*CONFAY URB(I)=IEL(2,J,21) STORM(I)=IEL(2,J,22) CURB(I)=IEL(2,J,24) !RZ URBAN:: above are flags for urban cells, stormwater drains, and curbs, respectively C C **** IF CHANNEL SLOPE NOT SPECIFIED, ASSUME IT'S HALF OVERLAND SLOPE. C IF (SS(I).LE.0.) SS(I)=.50*SL(I) TIAL(I)=0 !WB tile drainage flag = false; rwz this is not a logical operator IF (IELC(2,J,2).NE.ISTL) GO TO 120 !WB ISTL = 'TI' = IS TiLe TIAL(I)=256 !WB this is supposed to be the tile drainage flag TBAR=TBAR+1. !WB TBAR = percent of elements tiled? 120 M=DBLE(IEL(2,J,5))/90.+1. !WB the prev line reads the flow angle, divides it by 90 and adds 1, !WB and then rounds the number, it tells the quad # MM1=M-1 !WB this is set up to tell how many quads come before M C C **** EVALUATE OUTFLOW PROPORTIONS TO ADJACENT COLUMN AND ROW ELEMENTS. C ANG=(DBLE(IEL(2,J,5))-90.*DBLE(MM1))*.01745329 !WB the ang calculates the angular difference from the nearest (previous) !WB horizontal or vertical axis, in rads (!RWZ .01745329 is pi/180) X=SIN(ANG)+COS(ANG) !WB not really sure what this is for yet !WB this is opposite/hyp + adj / hyp = opp+adj / (hyp) IX=CHAN(I) !WB IX is the width # IF (IX.EQ.0) GO TO 130 !WB if the channel width/type is 0, go to 130 !WB and skip over the channel conveyance calculations C C **** EVALUATE CONVEYANCE FOR CHANNEL ELEMENTS. C !WB this section appears to create a separate counter that keeps !WB track of channel segments. As this loop goes through performing !WB calculations, if there is a channel segment it is recorded here !WB and its width, slope (which may be a little awry), and !WB conveyance are calculated (which uses the variable PIV). II=II+1 !WB II appears to be a counter, and it only works if the element !WB has a channel element in it CHNUMBER(II)=CHNUM(I) !WB THIS DESIGNATES THAT THE CHANNEL DESIGNATOR # OF ELEMENT II IS EQUAL !WB TO THE CHANNEL DESIGNATOR # OF THE CURRENT ELEMENT. THIS IS USED !WB TO EXTRACT CWID,SS,PIV LATER. CHNSOIL(II)=CHNSL(I) !WB CHNSOIL(II)=CHANNEL SOIL TYPE CHNURB(II)=URB(I) !RZ LOOK AT ME MNCHNSL(II)=MNCS(IX) !WB MNCHNSL=MANNING'S N FRIC FACT. FOR THIS CHANNEL SOIL, INPUT ABOVE MNCHNTOT(II)=MNCT(IX) !WB MNCHNTOT=MANNING'S N FRIC FACT. FOR THIS CHANNEL SOIL + VEG CWID(II)=WID(IX) !WB width of segment i = width of identifier IX ROCKBOT(II)=IMPERM(IX) !WB ROCKBOT = DEPTH TO IMPERMEABLE LAYER NOERODE(II)=ARMOUR(IX) !WB NOERODE = THE FRACTION OF THE CHANNEL CELL THAT IS NONERODIBLE, !WB OR ARMORED. THIS IS USED TO ADJUST DETACHMENT IN THE CHANNEL !WB EROSION MODULE. SS(II)=SS(I) !WB channel slope for element is equal to slope for channel, I is !WB reclassified to be the # of the element IF (SS(I).LT.SCMIN) SCMIN=SS(I) IF (SS(I).GT.SCMAX) SCMAX=SS(I) !WB these set the slope in the channel cell. SCBAR=SCBAR+SS(I) !WB average slope? PIV(II)=CONST/CN(IX)/X*(DX/WID(IX)/X)**0.6667*DSQRT(SS(I)) !WB PIV is used to record conveyance = flow depth conversion / !WB (manning's N for channel width !WB #) / (sin ang + cos ang) * (cell width / width / (sin ang + cos ang) !WB ^0.6667*sqrt(element slope)) !RZ In other parts of the program, PIV is the air-filled pore space; I think !RZ this calculation, which is similar to the conveyance calculation B(I) is !RZ trying to somehow represent the open channel as an air-filled space that water !RZ can fill. CONSTHLD(II)=CONST XHOLD(II)=X !WB THE ABOVE VARIABLES ARE USED TO HOLD PLACES SO THAT CONVEYANCE !WB CAN BE CALCULATED FOR EACH TIME STEP WHEN ITS RAINING AND THE !WB PROPER FLOW CAN BE EXTRACTED AND ADJUSTED FOR CHANNEL WIDENING C C **** NOW DETERMINE THE ELEMENT(S) THAT RECEIVE OUTFLOW FROM THE C **** CURRENT ELEMENT. NOTE: IT IS LEGAL FOR AN ELEMENT WITH A C **** SHADOW CHANNEL ELEMENT TO SHOW FLOW, AT THIS TEST POINT, THAT C **** WOULD OTHERWISE BE OUTSIDE THE CATCHMENT. C C **** NRZ 9/11/94 C **** THIS SECTION HAS BEEN MODIFIED TO ACCEPT MULTIPLE OUTLETS C **** LINE 130 FINDS THE APPROPRIATE ERROR CHECK BASED ON THE QUADRANT C **** THAT THE OUTFLOW IS DIRECTED FROM NOUTFL=0 130 IF (CALLBMP(I).EQ.1) THEN IF (SUB(POND(I)).EQ.1) THEN CONTINUE GOTO 220 END IF END IF !WB flow out of watershed flag GO TO (140,150,150,140,140), M !WB If M is equal to 1,2,3,4,5 then the !WB program is directed in that manner. !RZ This determines which way the water flows in the row direction. 140 DO 141 NCH=1,NCHAN !WB do from 1 to the # of channels IF (NOUTFL.EQ.1) GOTO 142 !WB if the flow out of the watershed flag = true, then goto 142 IF ((J.GE.JMAX.OR.IEL(2,J+1,3).EQ.0).AND.CHAN(I).EQ.0.AND. 1IEL(2,J,5).NE.270.AND.I.NE.MOUT(NCH)) THEN !WB if the column # of the element is ge the max # of columns or if !WB the element # of the next column equal 0 and the channel width !WB designator equals 0 and the flow direction doesn't equal 270 !WB and the element counter # ne the outlet cell of the channel. !WB shouldn't the first message be an error message? !RZ This isn't an error message, it just lets the user know that the !RZ flow is routed partially out of the watershed. JMAX is the max !RZ number of columns, so if you have this condition, you are on the !RZ edge of the watershed; the 2,J+1,3 is the cell beside you, if !RZ this is zero, this also indicates that you are on the edge of !RZ the watershed (cells outside the watershed have zero for this !RZ value because there is an array slot for them never filled); !RZ if iel(2,j,5) is 270, this indicates the flow is totally in !RZ the column direction (think quadrants) so later on RFL will !RZ be zero for this cell and the cell will not actually leak WRITE (2,770) IEL(2,J,1),J !WB write element # row, column, flows out of the watershed NOUTFL=1 !WB set the outflow flag equal to 1 ENDIF 141 CONTINUE 142 NR(I)=IEL(2,J+1,3) !WB element # receiving flow from element i in the row direction IF ((J.GE.JMAX.OR.IEL(2,J+1,3).EQ.0).AND.(CHAN(I).NE.0).AND. 1IEL(2,J,5).NE.270.AND.(IEL(2,J,5).NE.0).AND.(IEL(2,J,5).NE.360). 2AND.I.NE.MOUT(NCH)) THEN IF(M.EQ.1) NR(I)=IEL(1,J+1,3) IF(M.EQ.4) NR(I)=IEL(3,J+1,3) DIAGFLAG(I)=1 END IF !RZ The above if-then was added 4/22/2002 by Rebecca Zeckoski (also all !RZ corresponding segments after 152,162, and 172) to allow channel !RZ segments to exist on watershed boundaries. As the user should know !RZ ANSWERS allows channel cells to flow diagonally; HOWEVER, previously !RZ the way this section worked a channel cell flowing diagonally on !RZ a watershed boundary was termed a leaky cell and caused the program !RZ to crash, because the actual element receiving flow was not !RZ designated (became NMAX+ISTRUC+2, really messed things up). NOW, !RZ the program checks as before for a cell on the boundary, !RZ only this time, it is looking for a channel cell (chan(i).ne.0) and !RZ if the flow is exactly horizontal, an error is still given because !RZ realistically that should not happen, indicates an error in the input !RZ file possibly caused by not aligning the landuse and/or soils layers !RZ correctly in ArcView. NOUTFL=0 !WB reset the outflow flag to 0 GO TO (160,160,170,170,160), M !WB still not really sure what this is supposed to do !RZ I think it tells the program where to go based on the aspect of the !RZ cell - i.e., which direction to route the flow in the column direction !RZ (think quadrants) 150 DO 151 NCH=1,NCHAN !WB do from 1 to # of channels IF (NOUTFL.EQ.1) GOTO 152 !WB if the outflow flag = 1, goto 152 IF ((J.LE.1.OR.IEL(2,JM1,3).EQ.0).AND.CHAN(I).EQ.0.AND. 1IEL(2,J,5).NE.90.AND.I.NE.MOUT(NCH)) THEN !WB if the column # of the current element le 1 or if the element !WB # of the previous column equals 0 and the channel width # equals !WB to 0 and the flow direction ne 90 and the element # ne the outlet !RZ see discussion at 140 for explanation WRITE (2,770) IEL(2,J,1),J !WB write that this cell flows out of the watershed at its row and !WB column NOUTFL=1 !WB reset the leaky cell flag to 1 and continue ENDIF 151 CONTINUE 152 NR(I)=IEL(2,JM1,3) !WB the element # receiving flow from this cell in the row direction !WB is the previous cell # IF ((J.LE.1.OR.IEL(2,JM1,3).EQ.0).AND.(CHAN(I).NE.0).AND. 1IEL(2,J,5).NE.90.AND.(IEL(2,J,5).NE.180).AND.I.NE.MOUT(NCH)) THEN IF (M.EQ.2) NR(I)=IEL(1,JM1,3) IF (M.EQ.3) NR(I)=IEL(3,JM1,3) DIAGFLAG(I)=1 END IF GO TO (160,160,170,170,160), M !WB directing flow based on the value of M (1,2,3,4,5? or 1,2,3,4,0?) !RWZ it is 1,2,3,4,5; the quadrant #; only get a 5 if the flow angle !RWZ is 360 b/c of way quadrants are assigned (see line# 120 in this !RWZ subroutine to see how M is calculated); quadrants 1,2,5 have positive !RWZ 'y' values; quadrants 3 and 4 have negative 'y' values - sends the !RWZ program to the column routing portion of flow routine calculations 160 DO 161 NCH=1,NCHAN IF (NOUTFL.EQ.1) GOTO 162 IF (IEL(1,J,3).EQ.0.AND.IEL(2,J,5).NE.0.AND.CHAN(I).EQ.0.AND. 1IEL(2,J,5).NE.360.AND.I.NE.MOUT(NCH)) THEN !WB if the element number of the cell above this one equals 0 and !WB the slope ne 0 and channel width # equal 0 and slope ne 360 and !WB the element # ne the outlet of a channel WRITE (2,770) IEL(2,J,1),J !WB write that this cell leaks NOUTFL=1 ENDIF 161 CONTINUE 162 NC(I)=IEL(1,J,3) !WB mark the element # receiving flow from this cell in the column !WB direction equal to element # above it IF (IEL(1,J,3).EQ.0.AND.IEL(2,J,5).NE.0.AND.(CHAN(I).NE.0).AND. 1IEL(2,J,5).NE.360.AND.(IEL(2,J,5).NE.0).AND.(IEL(2,J,5).NE.90). 2AND.I.NE.MOUT(NCH)) THEN IF(M.EQ.1) NC(I)=IEL(1,J+1,3) IF(M.EQ.2) NC(I)=IEL(1,JM1,3) DIAGFLAG(I)=1 END IF GO TO 180 !WB jump over the next section 170 DO 171 NCH=1,NCHAN IF (NOUTFL.EQ.1) GOTO 172 IF (IEL(3,J,3).EQ.0.AND.IEL(2,J,5).NE.180.AND.I.NE.MOUT(NCH).AND. 1CHAN(I).EQ.0) THEN !WB if the element # below this cell equals 0 and the slope doesn't !WB equal 180 and the element # ne a channel outlet and the chan width !WB # equals 0; !RZ see discussion at 140; this time we are checking for all !RZ flow occurring in the row direction (iel(2,j,5)=180) WRITE (2,770) IEL(2,J,1),J !WB write that this cell leaks NOUTFL=1 !WB set the outflow flag = 1 ENDIF 171 CONTINUE C *** NRZ 9/11/94 172 NC(I)=IEL(3,J,3) !WB route the flow in column direction to the cell below it IF (IEL(3,J,3).EQ.0.AND.IEL(2,J,5).NE.180.AND.(IEL(2,J,5).NE.270). 1AND.I.NE.MOUT(NCH).AND.(CHAN(I).NE.0)) THEN IF(M.EQ.3) NC(I)=IEL(3,JM1,3) IF(M.EQ.4) NC(I)=IEL(3,J+1,3) DIAGFLAG(I)=1 END IF 180 IF (ANG.GT..78539816) GO TO 190 !WB if angle from the axis is greater than 45 degrees RFL(I)=.5*SIN(ANG)/COS(ANG) !WB fraction of discharge from element flowing in row direction !WB is equal to 0.5 (opposite/hyp) / (adjacent/hyp) = 0.5 (opp/adj) !WB angles less than 45 degrees will always be within 45 degrees of !WB a major axis, on the plus side (ex: 90+45, 180+45, etc) GO TO 200 190 RFL(I)=1.-.5*SIN(1.5707963-ANG)/COS(1.5707963-ANG) !WB fraction of discharge from element flowing in row direction = !WB 1-0.5*sin(90-ang)/cos(90-ang) 200 GO TO (210,220,210,220,210), M !WB M is the quadrant # 210 RFL(I)=1.-RFL(I) !WB fraction of flow in row direction equals 1-the above calculation C C **** ELIMINATE FALSE RECEIVING ELEMENTS WHICH MAY CAUSE OUT-OF-RANGE C **** SUBSCRIPTS FOR SOME BOUNDARY ELEMENTS. C 220 IF (RFL(I).LT.0.01) NR(I)=NC(I) !WB if the fraction of discharge from element in row direction is !WB less than 0.01, then the number of the element receiving flow in !WB the row direction is equal to the number of the element receiving !WB flow in the column direction IF (RFL(I).GT.0.99) NC(I)=NR(I) !WB similar to above, but other direction !RZ CALL THE URBANIZED SUBROUTINE IF THE URBAN W/CURBS FLAG IS TRIGGERED !RZ OR IF THE STORMWATER DRAIN FLAG IS TRIGGERED IF ((IEL(2,J,22).EQ.1).OR.(IEL(2,J,24).EQ.1)) THEN URBAN = 3 IDUMMY=0 DUMMY=0. CALL URBANIZED(URBAN,J,JM1,IEL,JMAX,NPAR2,ISTRUC,IDUMMY, 1IDUMMY,IDUMMY,CDUMMY,I,CDUMMY,A3DUMMY,IELC,DUMMY,DUMMY,DUMMY,DUMMY 1,DUMMY,IDUMMY,IDUMMY,LCC,LCR,CROP) END IF C C **** "LEAKY" ELEMENTS (THOSE WITH PARTIAL FLOW OUTSIDE THE WATERSHED) C **** MUST DIVERT THAT PARTIAL FLOW INTO A SPECIAL PSUEDO ELEMENT. C C **** NRZ 9/11/94 C **** MODIFY CHECK FOR ALL OUTLETS DO 223 NCH=1,NCHAN IF (NC(I).GT.0.OR.I.EQ.MOUT(NCH)) GO TO 230 !WB if the number of element receiving flow from this element in the !WB column direction gt 0 or the element # is a an outlet, goto 230. !WB This says that the element isn't a leaky element or it's a !WB channel outlet. 223 CONTINUE C C **** THIS ELEMENT LEAKS, DIVERT IT INTO SPECIAL "BOTTOMLESS PIT". C **** MARK THIS CELL AS LEAKY IN THE COLUMN DIRECTION WITH FLAG ARRAY C **** LCC NC(I)=NMAX+ISTRUC+2 !WB the element # receiving flow from this element is equal to the !WB max # of cells + # of structures + 2 !WB shouldn't this be equal to NMAX + ISTRUC + NCHAN + 2 ? !RZ NO - NMAX is the maximum number of POSSIBLE cells (35000) - this !RZ includes overland flow and channel cells. !RZ On further reflection - there is a discrepancy in the definition !RZ of NMAX and NCHAN in the program. So this may or may not be correct. LCC(I)=1 !WB LCC = flag indicating cell leaks !RZ Leaky Cell Column C C **** ADD TO TOTAL NON-CONTRIBUTING AREA. C OUTSID=OUTSID+1.-RFL(I) !WB the flow to outside the watershed = same + column flow from this !WB element C **** NRZ C **** MODIFY CHECK FOR ALL OUTLETS C 230 IF (NR(I).GT.0.OR.I.EQ.MOUT) GO TO 240 230 DO 233 NCH=1,NCHAN IF (NR(I).GT.0.OR.I.EQ.MOUT(NCH)) GO TO 240 !WB if the element # receiving flow from this element in the row !WB direction is gt 0 or the element # is equal to a channel outlet !WB this and the above statement say that if the receiving element !WB is numbered 0 and is not a channel outlet then its a leaky cell 233 CONTINUE C **** NRZ C **** MARK THIS CELL AS LEAKY IN THE ROW DIRECTION WITH FLAG ARRAY C **** LCR C NR(I)=NMAX+ISTRUC+2 !WB the element # receiving flow in the row direction is equal to !WB the max # of overland cells+# of structures+2 !WB shouldn't this equal NMAX + ISTRUC + NCHAN + 2 ? !RZ NO-NMAX is the maximum number of POSSIBLE cells - 35000 - which !RZ includes overland flow and channel cells !RZ On further reflection - there is a discrepancy in the definition !RZ of NMAX and NCHAN in the program. So this may or may not be correct. LCR(I)=1 !WB flag it as leaky in the row direction !RZ Leaky Cell Row OUTSID=OUTSID+RFL(I) !WB add its contribution to flow outside the watershed C **** NRZ 9/15/94 C C **** GET CROP/MGMT NUMBER. C 240 I1=IEL(2,J,7) !WB I1 is the rotation # CBAR(I1)=CBAR(I1)+1. !WB CBAR is supposed to be percent of watershed in crop i !WB Each time that you go through this loop, you add 1 (a cell) !WB of each crop type to the percent of watershed in crop i. C C **** PUT CROP/MANAGEMENT NUMBER IN LOW BYTE AND SOIL TYPE NUMBER IN C **** NEXT BYTE OF (SOIL:SUR). C **** NRZ 3/26/95 C **** CROP/MANAGEMENT NUMBER IS THE ROTATION NUMBER - NOT CROP NUMBER C C **** NRZ 9/5/94 C **** DIVIDE IEL(2,J,6) BY 10000 TO ACCOUNT FOR ADDITION OF CHANNEL C **** NETWORK DESIGNATOR C K=MOD(IEL(2,J,6),100) K=MOD(MOD(MOD(IEL(2,J,6),1000000),10000),100) !WB K = SOIL TYPE # OF OVERLAND FLOW CELL C **** NRZ 9/5/94 SPER(K)=SPER(K)+1. !WB steady state infiltration rate for the soil type = same +1 !WB so every time you go through and this soil type is present, !WB you add 1 to that value. Maybe its a percent of the !WB watershed with that ss infil rate? !RZ I believe this is wrong. I think SPER is a counter to tell how many cells !RZ have a particular soil type. Here SPER is incremented each time a cell of each !RZ particular type comes along. SPER stands for Soil PERcent. SOIL(I)=(K*256)+I1 !WB soil type for element i = (soil type # * 256) + rot # C **** NRZ 3/26/95 C **** FAYCAL MADE THIS CHANGE, THIS IS MY COMMENT C **** IROT(I1,2) IS THE CROP # FOR THE FIRST CROP IN ROTATION I1 !WB CORRECT COVER CHOSEN IN MAIN ROUTINE * SUR(I)=(K*256)+IROT(1,2) SUR(I)=I1*256+IROT(I1,2) !WB surface type on element i = (rot # * 256) + first crop in rot I1 C **** NRZ 3/26/95 !RZ URBAN:::ASM AND FCAP ARE NOT DEFINED FOR URBAN SOIL TYPES IF (URBSOIL(K).EQ.1) GO TO 249 ASMBAR=ASMBAR+ASM(K) !WB average ASM = same + asm of soil type # FPBAR=FPBAR+FCAP(K) !WB the variable list says that this isn't used !RZ URBAN 249 CONTINUE C **** NRZ 8/5/95 C **** RN(I1) SHOULD BE MANNING'S N FOR THE CROP # OF THE CROP IN THE CURRENT C **** ROTATION. AS CODED BEFORE, IT WAS MANNING'S N FOR THE ROTATION #, WHICH C **** MAY NOT HAVE BEEN DEFINED IF THERE WERE MORE ROTATIONS THAN CROPS. !WB actually, RN(IROT(I1,2)) is manning's n of the first crop in the !WB rotation #, so this may not be correct * B(I)=CONST*DSQRT(SL(I))*X/RN(I1) B(I)=CONST*DSQRT(SL(I))*X/RN(IROT(I1,2)) !WB conveyance B(I) = depth conversion * sqrt (slope of element) * !WB sin(ang) + cos(ang) / reynold's # of 1st crop in the rotation C C **** MAKE SPECIAL ADJUSTMENTS TO ACCOUNT FOR STRUCTURAL PRACTICES, C **** BUT FIRST SEE IF ANY ARE PRESENT IN THIS ELEMENT. C IF (IEL(2,J,9).NE.0) CALL STRUCT (I,J,RFL(I),IEL,JMAX, 1NPAR,NMAX,STRUC,NSTRUC,ISTRUC,X,DX,WID,SS(II+1),SS(I),PIV(II+1),CN 2,CWID(II+1),CHAN(I),CONST,SL(I),II,SCMIN,SCMAX,SCBAR,ANG,IELC,NPAR 32,CALLBMP,HASOPENED) !WB if the structural flag ne 0, then a structure is present and the !WB appropriate subroutine needs to be called. DO 250 K=1,NRG IF (IELC(2,J,1).EQ.IG(K)) GO TO 260 !WB if the element of the array equals the raingage designator name 250 CONTINUE WRITE (2,600) IELC(2,J,1),IEL(2,J,1),J,IG(1) K=1 !WB this says that if the IELC doesn't equal the raingage designator !WB name, then write that the raingage identifier is missing C C **** PUT RAINGAGE NUMBER IN LOW BYTE AND TILE NUMBER IN NEXT BYTE C **** OF (TIAL:RANE). C 260 RANE(I)=TIAL(I)+K !WB number of rain gage applicable to element i = tile flag + (K=1) !WB should rane(I) be dimensioned to 2000 also? !RZ it seems to me that K<>1! If the program gets to K=1, it is b/c !RZ the raingage identifier is missing; K is set to a default of 1 in that case. !RZ normally K would be the raingage number for the soil! 270 CONTINUE !WB************************************************* !WB end of do loop for doing the current row's calculations !WB************************************************* JS=IEL(3,1,2) !WB this is the last column # of the third row I think IF (ITEMP(3).NE.999.AND.IEL(3,JS,1).NE.ITEMP(1)) GO TO 110 !WB if the last element in a row flag ne 999 (its only supposed to !WB be a 9) and the row number of the last column in the IEL array !WB ne the row # currently read in the itemp(1) array, then go back !WB to the top to redo subroutine relem ITEMP(3)=999 !WB okay, you set itemp(3) equal to 999, which flags the program !WB that you are on the last row in the watershed IF (JS.NE.JMAX) GO TO 110 !WB if the last column # of the row ne the maximum column #, go back !WB to the top and redo subroutine relem IF (N+II.GT.NMAX) GO TO 520 !WB if the # overland flow cells + channel segments is greater than !WB the max # of cells, then jump down and stop the program X=N ASMBAR=ASMBAR/X FPBAR=FPBAR/X SB=AREA2 AREA=AREA2*(X-OUTSID) CONV=CU*(X-OUTSID) SBAR=SBAR/X !WB I guess that this is part of the statistical output from the !WB watershed IF (II.GT.0) SCBAR=SCBAR/DBLE(II) NN=N+1 !WB this says that if the II counter (for channels) is gt 0, then !WB relabel NN to be the low counter for the channel networks C C **** OUTPUT STATISTICAL SUMMARY OF WATERSHED CHARACTERISTICS. C TBAR=TBAR/X * NRZ 9/11/94 * CHANGE OUTPUT PRINT LINE TO PRINT MULTIPLE OUTLET CELLS C WRITE (2,690) TITLE,SB,PP(IT+3),N,II,AREA,PP(IT+3),SMIN,SBAR,SMAX, C 1SCMIN,SCBAR,SCMAX,TBAR,DC,PP(IT+1),ASMBAR,FPBAR,GRF,MOUT,NIOUT,NJO C 2UT WRITE (2,690) TITLE,SB,PP(IT+3),N,II,AREA,PP(IT+3),SMIN,SBAR,SMAX, 1SCMIN,SCBAR,SCMAX,TBAR,DC,PP(IT+1),ASMBAR,FPBAR,GRF WRITE (2,695) (NCH,MOUT(NCH),NIOUT(NCH),NJOUT(NCH),NCH=1,NCHAN) WRITE (2,*) * NRZ 9/11/94 WRITE (2,700) PP(IT+1),PP(IT+2) DC=DC*CU/24. !WB tile drainage coefficient = same * (mm/h to m3/s) / 24 SB=CONST*DSQRT(SBAR)/RN(1) !WB SB = average overland flow conveyance coeff !WB SB=depth conversion*sqrt(average catchment slope)/Manning's n !WB for surface type 1 !WB check the Reynold's # for accurate selection J=0 DO 330 I=1,ICR !WB ICR = # of cropping practices IF (CBAR(I).LE.0..AND.I.LT.ICR) GO TO 330 !WB cbar is the percent of watershed in crop i, I is the # of !WB cropping practices CBAR(I)=CBAR(I)/X !WB X is the # of overland flow cells IF (J.GE.ISR) GO TO 320 !WB this seems to be an imbedded count/do-while loop is greater !WB than # of soil types, when the # of cropping practices exceeds !WB the # of soil types, jump down to 320 280 J=J+1 DO 300 JJ=J,ISR !WB do to # of soil types IF (SPER(JJ).LE.0.) GO TO 300 !WB if steady-state infiltration rate less than or equal 0 !RZ I believe this is wrong. SPER is the number of cells with soil type !RZ JJ; therefore, if SPER<=0., there are no cells with the particular soil !RZ type and the rest of the calculations don't need to be done. SPER probably !RZ stands for Soil PERcent. !RZ URBAN:::SKIP CLAY AND FC CALCULATIONS IF THE SOIL TYPE IS URBAN IF (URBSOIL(JJ).EQ.1) GO TO 281 CLAYAV=CLAYAV+CL(JJ)*SPER(JJ)/100. !WB average clay = same + clay content of soil type * steady-state !WB infil rate / 100 !RZ SPER = number of cells with JJ soil type, not steady-state infil rate !RZ SPER probably stands for Soil PERcent; thus, this is accumulating clay average !RZ (percent clay in soil jj * number of cells with soil jj / 100 !RZ makes it a percent? something like that, you're adding a fraction !RZ to the total clay average for the entire watershed *FC REPRESENT THE WILTING POINT FPBAR=FC(JJ) !WB the notes say that FPBAR is not used = wilting point 281 CONTINUE SPER(JJ)=SPER(JJ)/X !WB steady-state infil rate = same / # of cells? Represents !WB percent of watershed in that rate? !RZ I believe this is wrong. SPER is the number of cells with soil type JJ, !RZ so this determines the fraction of the watershed with soil type JJ. SPER !RZ probably means Soil PERcent. IF (CBAR(I).LE.0.) GO TO 290 !WB if the percent of watershed in crop practice i is le 0, skip the !WB write statement WRITE (2,710) CROP(I,1),CROP(I,2),CBAR(I),PER(I),RN(I),JJ,S 1PER(JJ),KS(JJ),DF(JJ) CBAR(I)=0. !WB reset the % of watershed in crop i to 0. It gets set above. GO TO 310 290 WRITE (2,720) JJ,SPER(JJ),KS(JJ),DF(JJ) GO TO 310 300 CONTINUE J=ISR GO TO 320 310 J=JJ IF (I.LT.ICR) GO TO 330 !WB if the cropping practice counter # is lt # of cropping practices !WB then jump down to 330 and go back to the top (b/c 330 is end of loop) IF (J.LT.ISR) GO TO 280 !WB if the J counter in this loop is lt # soil types, go back to !WB the top and redo the soil properties loop 320 IF (CBAR(I).GT.0.) WRITE (2,730) CROP(I,1),CROP(I,2),CBAR(I),PER(I 1),RN(I) 330 CONTINUE !WB end of this loop C *** NRZ 9/15/94 C *** PRINT OUTPUT HEADER TO ALL OUTPUT FILES DO 332 NCH=1,NCHAN+1 NUNIT=NCH+10 WRITE(NUNIT,1700) WRITE(NUNIT,*) ' DAY RAIN RUNOFF SEDIMENT NO3 DIS-NH4' &,' SED-NH4 DIS-PO4 SED-PO4 SED-TKN' WRITE(NUNIT,*) ' MM MM KG/HA KG KG' &,' KG KG KG KG' 332 CONTINUE C *** ASSIGN AN OUTLET CELL FOR EACH CHANNEL NETWORK OUTLET DO 335 NCH=1,NCHAN+1 IF (NCH.LE.NCHAN) THEN CHOUT(NCH)=N+II+NCH NR(MOUT(NCH))=CHOUT(NCH) NC(MOUT(NCH))=CHOUT(NCH) !WB these set the element # receiving the flow from the outlet !WB cell equal to the channel out # !RZ Recall this is network outlet, not channel outlet !WB what about ISTRUC? ELSE CHOUT(NCH)=N+II+NCH !WB This is used to track the leakycell.out a couple of lines down. !WB chout is dimensioned to 9!!!! ENDIF 335 CONTINUE !WB THE NEXT SECTION RENUMBERS THE CHANNEL CELLS NUMBERED N+1 UP TO !WB II. THEY ARE ORIGINALLY NUMBERED LINEARLY ACCORDING TO WHETHER !WB OR NOT THEY HAVE A CHANNEL CELL IN THEM. IN THE ABOVE SECTION, !WB THEY ARE EXTRACTED FROM THE LINEAR ORDER. BELOW, THE VALUES ARE !WB ATTRIBUTED TO THEM, HOWEVER THE VALUES ARE NOT RENUMBERED ACCORDING !WB TO THE CHANNEL SERIES TO WHICH THEY BELONG (THEY ARE STILL IN !WB LINEAR ORDER), SO THIS ROUTINE RENUMBERS THEM INTO ORDER BY !WB CHANNEL SEG TO WHICH THEY BELONG. !WB BEGIN RENUMBER CHANNEL SEGMENTS IF (II.NE.0) THEN I1=1 DO NCH=1,NCHAN DO CNT=1,II IF (CHNUMBER(CNT).EQ.NCH) THEN !SHOULD BE CHANNEL NETWORK IDENTIFIER PIVTMP(I1)=PIV(CNT) CWIDTMP(I1)=CWID(CNT) SSTMP(I1)=SS(CNT) MNCSTMP(I1)=MNCHNSL(CNT) MNCTTMP(I1)=MNCHNTOT(CNT) RBTEMP(I1)=ROCKBOT(CNT) CHNSLTMP(I1)=CHNSOIL(CNT) CONSTTMP(I1)=CONSTHLD(CNT) XTMP(I1)=XHOLD(CNT) NERODTMP(I1)=NOERODE(CNT) CHNURBTMP(I1)=CHNURB(CNT) I1=I1+1 ENDIF END DO END DO ENDIF !WB END RENUMBER CHANNEL SEGMENTS C *** NRZ 9/15/94 * CHECK TO SEE IF THERE ARE ANY CHANNEL SEGMENTS IF (II.NE.0) GO TO 340 N2=N !WB if there are no channel segments, set the high N equal to the !WB # of overland flow cells, and jump over the continuity section GO TO 410 C C **** DETERMINE SHADOW ELEMENT CONTINUITY. C **** FIND CHANNEL SEGMENTS. C C **** NRZ 9/5/94 C **** REPEAT CHANNEL SEGMENT CONTINUITY CHECK FOR EACH CHANNEL C **** NETWORK ON THE FARM 340 DO 405 NCH=1,NCHAN+1 DO 350 J=1,N C **** IF CELLS LEAK, ROUTE THEM TO THE LEAKY CELL OUTLET CELL IF (NCH.EQ.NCHAN+1) THEN IF (LCC(J).EQ.1) NC(J)=CHOUT(NCH) !WB if the leaky cell column direction flag = 1, then the # of the !WB element receiving flow in the column direction = the outlet cell !WB for the channel IF (LCR(J).EQ.1) NR(J)=CHOUT(NCH) !WB if the leaky cell in the row direction flag = 1, then the !WB number of the element receiving flow in the row direction is !WB equal to the outlet cell of the channel ENDIF IF ((CHAN(J).EQ.0).OR.(CHNUM(J).NE.NCH)) GO TO 350 !WB if channel width # = 0 or channel # designator ne the !WB channel counter, so if there is no channel in this cell or !WB if the channel # of the loop isn't the same as the channel !WB in this cell. This extracts all channel cells of one type. C C **** USE THE ROW FLOW POINTER TO REMEMBER ORIGINAL ELEMENT NUMBER C **** OF THIS CHANNEL ELEMENT, SINCE THE FLOW COMPONENT IN THE ROW C **** DIRECTION IS 0. C NR(NN)=J WRITE(2,*) NN,J !WB the original overland flow cell # is equal to !WB the element counter #, is originally set to n+1 !WB NN is another counter used to track channel cells MYSHADOW(NN)=J IF (CALLBMP(J).EQ.1) THEN CALLBMP(NN)=1 ! CALLBMP(J)=0 POND(NN)=POND(J) ! POND(J)=0 IF (SUB(POND(J)).EQ.0) THEN POND(J)=MAXPOND+1 MAXPOND=MAXPOND+1 SUB(POND(J))=1 SUB(POND(NN))=0 END IF !RZ URBAN:make sure the callbmp flag is passed to the channel cell if necessary; !RZ Okay, here's the new deal. Overland flow is calculated on the shadow cells and !RZ we don't want that. So we need the pond and callbmp designations to remain with the !RZ o.f. cells so that in the main program overland flow will not be calculated, and !RZ instead all water coming onto those cells will be directed to nr and nc. For these !RZ particular cells (see later), nr and nc are reassigned to be the channel cells. The !RZ channel cells have their nc assigned as the outlet cell of the o.f. cell, which !RZ we specified in subroutine bmps as the pond collection point. Now the one exception !RZ to this happy little scenario is when this is actually the pond collection point !RZ (hence the sub(pond(j)).eq.0 check). In this case, we need the pond characteristics !RZ to be assigned to the channel cell, as this is where everything is going to end up !RZ going. SO, we give the o.f. cell a dummy pond number that has no values, and !RZ reassign the part of larger (sub) variable to a 1 to indicate it is now part of !RZ a larger pond. Maxpond just keeps track of these dummy pond numbers to make sure !RZ none of the original pond numbers are overwritten. The part of larger (sub) variable !RZ is set to 0 for the channel cell to indicate that it now is the pond collection point, !RZ it contains all the pond characteristics, and when the main program hits this cell it !RZ will perform the pond calculations. Hopefully that makes sense to you :-). END IF NN=NN+1 350 CONTINUE IF (NCH.EQ.NCHAN+1) GOTO 405 !WB if the channel counter equals the leakycell place holder, goto 405 C C **** MOVE CHANNEL PARAMETERS TO END OF ARRAYS. C **** NRZ C **** CHANGE LOWER BOUND (N1) OF CHANNEL CELL SECTION OF ARRAY TO C **** ACCOUNT FOR NEXT CHANNEL NETWORK IF (NCH.NE.1) THEN NLOW=N2+1 ELSE NLOW=N+1 ENDIF N1=NLOW C **** NRZ N2=NN-1 DO 390 I=N1,N2 C **** NRZ 3/25/95 C **** I1 IS THE NUMBER OF THE CHANNEL SEGMENT IN THIS NETWORK (i.e. IF C **** THIS IS NETWORK #2 AND NETWORK #2 HAS 10 CHANNEL SEGMENTS, I1 WILL C **** RANGE FROM 1-10) I1=I-N B(I)=PIVTMP(I1) !WB this is conveyance? = the PIV variable is set equal to the !WB channel conveyance (I believe) in previous lines CWID(I)=CWIDTMP(I1) !WB channel width of this cell is equal to the channel width of the !WB segment SL(I)=SSTMP(I1) !WB slope of the overland cell = slope of the channel segment MNCHNSL(I)=MNCSTMP(I1) !WB THIS IS THE MANNING'S N FOR BARE CHANNEL SOIL. MNCHNTOT(I)=MNCTTMP(I1) !WB THIS IS THE MANNING'S N FOR CHANNEL SOIL + VEG. ROCKBOT(I)=RBTEMP(I1) !WB DEPTH TO IMPERMEABLE LAYER FOR CHANNEL CELL CHNSOIL(I)=CHNSLTMP(I1) !WB CHNSOIL = SOIL TYPE FOR CHANNEL CELL SOIL(I)=CHNSOIL(I)*256 !WB THIS SETS THE SOIL TYPE IN THE CHANNEL CELL INTO THE SOIL ARRAY URB(I)=CHNURBTMP(I1) CONSTHLD(I)=CONSTTMP(I1) XHOLD(I)=XTMP(I1) !WB THE PREVIOUS TWO VALUES HOLD PLACE FOR CONVEYANCE CALCULATIONS IN THE MAIN !WB ROUTINE ARMOUR(I)=NERODTMP(I1) !WB FRACTION OF THE CHANNEL SOIL THAT IS NONERODIBLE C **** NRZ 3/25/95 C **** NR(I) IS THE ORIGINAL OVERLAND FLOW CELL #, NOT "NUMBER RECEIVING C **** ROW FLOW FROM (I)" J=NR(I) !WB recall J, which is an element with a channel series. The series !WB of the channel depends on how many times you've been through the !WB outer loop I1=NC(J) !WB I1 is equal to the element # that receives flow in the column !WB direction from the overland flow element I2=NR(J) !WB I2 is equal to the element # that receives flow in the row !WB direction from the overland flow element that contains a channel !WB of type that depends on the counter C C **** IF CERTAIN STRUCTURES ARE PRESENT IN AN ELEMENT WITH A SHADOW C **** ELEMENT, IT IS LIKELY THAT THE RECEIVING CHANNEL ELEMENT WILL C **** NOT BE GETTING THE MAJOR OUTFLOW. C IF (I1.GT.NMAX) GO TO 360 !WB If the # of the element that receives flow from the marker used !WB to designate a channel in an element exceeds the max # of cells, !WB then it implies that a structural element lies on the boundary !WB of this cell which contains a channel. Jump down to 360, set !WB the receiving element column # equal to the receiving element !WB row #, which means set the column flow equal to row flow. I would !WB think that this one should also point to 380. IF (I2.GT.NMAX) GO TO 380 !WB if the # of the element that receives flow from the marker used !WB to designate a channel in an element exceeds the max # of cells, !WB then it implies that a structural element resides on the !WB boundaries of this marker cell, and that you should check to see !WB if the receiving cell from this marker cell contains a channel !WB or if the marker cell is an outlet cell. If not it stops the !WB program. C C **** THIS ELEMENT DOES NOT CONTAIN A STRUCTURE; THEREFORE, THE C **** RECEIVING CHANNEL ELEMENT SHOULD BE IN THE DIRECTION OF THE C **** PREDOMINANT FLOW COMPONENT. C IF (RFL(J).LT.0.207107) GO TO 380 !WB flow in the row direction from the marker cell is !WB predominantly column IF (RFL(J).GT.0.792893) GO TO 360 !WB flow in the row direction from the marker cell is !WB predominantly row C C ****** FLOW DIRECTION IS PREDOMINANTLY DIAGONAL. C ****** IF ROW FLOW DESTINATION NUMBER IS LESS THAN CURRENT ELEMENT C ****** NUMBER, THE DIAGONAL POINTS TO THE LEFT AND THE DIAGONAL C ****** DESTINATION ELEMENT CAN BE COMPUTED BY SUBTRACTING ONE FROM C ****** THE CONVENTIONAL OVERLAND FLOW COLUMN DESTINATION NUMBER. C IF (DIAGFLAG(J).EQ.1) THEN IF ((NR(J).NE.J+1).AND.(NR(J).NE.J-1)) THEN I1=I2 END IF GO TO 380 END IF !RZ the above if was added 4/22/2002 by Rebecca Zeckoski as part of the !RZ new lines allowing diagonal flow for channel elements on the !RZ watershed boundary. If diagflag(j) is 1, the flow has already !RZ been calculated to be diagonal and a renumbering at this point !RZ would cause the flow to go to the wrong receiving cell. See !RZ the section above (140,150,160,170) to see how the flow direction !RZ has been calculated. !RZ The nested if then checks whether the column or row cell has the !RZ diagonal cell. If the row cell is not adjacent to this cell (as it !RZ would have to be if the flow destination had not been changed in !RZ the row direction to accomodate diagonal cells), this indicates !RZ that nr holds the diagonal cell and therefore i1, the receiving element !RZ of j, is reset to the cell in the nr position; otherwise, the column !RZ cell holds the diagonal element and i1=i1 (no change). IF (I2.LT.J) GO TO 370 I1=I1+1 GO TO 380 360 I1=I2 !WB element # that receives flow in the col direction from the !WB marker element = element !WB # that receives flow in the row direction from the marker cell. GO TO 380 370 I1=I1-1 !WB if the element # receiving row flow from J (marker cell) !WB is less than the marker element J #, then !WB the element # that receives flow from the marker cell is equal !WB to the # that it originally was, subtract 1. This is legitimate !WB because the o.f. routings do not calculate diagonal flow, and !WB therefore you will never be more than 1 column away from this !WB element C C **** MAKE CERTAIN THE RECEIVING ELEMENT IS A CHANNEL ELEMENT. C C **** NRZ 9/11/94 C **** THE FOLLOWING CHECK FOR DISCONTINUOUS CHANNELS IS PERFORMED FOR C **** EACH POSSIBLE OUTLET OF THE CHANNEL NETWORKS C NRZ 3/5/95 380 IF (CHAN(I1).LT.1.AND.J.NE.MOUT(NCH)) THEN WRITE(2,*) I1,J,CHAN(I1),CHAN(J) GO TO 560 END IF !WB if the channel width lt 1 and the element counter # ne the outlet !WB cell, goto 560 and stop the program C **** NRZ 9/11/94 C C **** TEMPORARILY ASSIGN THE ORIGINAL OVERLAND FLOW ELEMENT !WB*** destination NUMBER C **** AS THE DESTINATION FOR THE SHADOW OUTFLOW. THIS IS NECESSARY C **** UNTIL NEW NUMBERS ARE ASSIGNED TO ALL SHADOW ELEMENTS. C NC(I)=I1 !WB the element # receiving flow in the column direction from this !WB channel cell (I from N1 to N2) is equal to the calculated !WB column receiving # derived from the original o.f. cell C C **** MAKE ALL OVERLAND FLOW FROM THIS ELEMENT GO INTO ITS SHADOW C **** ELEMENT, UNLESS IT CONTAINS A STRUCTURAL PRACTICE. C NR(J)=I !WB the element # that receives flow from this marker element in the !WB row direction is equal to the number of this channel element NC(J)=I !WB the element # that receives flow from this marker element in the !WB column direction is equal to the number of this channel seg. 390 CONTINUE C C **** FIND REAL CHANNEL SEGMENT NUMBER INTO WHICH EACH CHANNEL C **** SEGMENT FLOWS. (rz instead of o.f. number of receiving cell) C DO 400 J=N1,N2 I=NC(J) !WB set I equal to the element # receiving flow from this element !WB in the column direction. This is equal to I1 from a few lines !WB above, it says to recall the outflow element # for the channel !WB segment. NC(J)=NR(I) !WB set the element # receiving flow in the column direction equal !WB to the element # receiving flow in the row direction !WB from the original overland flow cell C C **** IF THIS ELEMENT CONTAINS A STRUCTURAL MEASURE, ITS CORRECT C **** CHANNEL ELEMENT NUMBER MAY BE PRESENT ONLY IN ARRAY NC. C C IF (NC(J).GT.NMAX) NC(J)=NC(I) C C **** FORCE ALL CHANNEL FLOW TO USE ONLY COLUMN FLOW DIRECTIONS. C C **** NRZ 9/5/94 C **** INCORPORATE EXTRA OUTLETS AND DIRECT FLOW TO CORRECT FINAL C **** RECEIVING ELEMENT 400 RFL(J)=0. !WB set the fraction of flow in the row direction equal to 0 J=NR(MOUT(NCH)) !WB set the # J equal the element # receiving flow in the row !WB direction from the outlet cell # NC(J)=CHOUT(NCH) !WB set the element # receiving flow in the column direction from !WB the row element # above equal to the channel out variable for !WB the channel # C **** END OF MULTIPLE CHANNEL LOOP AND REASSIGN LOW VALUE OF CHANNEL C **** ELEMENT ARRAY 405 CONTINUE N1=N+1 C **** NRZ 9/5/94 C C **** OUTPUT DATA CONCERNING ANY STRUCTURAL PRACTICES. C !WB you are sent here to 410 if there are no channel segments 410 IF (.NOT.STRUC) GO TO 430 !WB the .struc flag must be set to 'true' if there are any practices WRITE (2,1000) DO 420 I=1,ISTRUC IF (NSTRUC(I).NE.0) WRITE (2,1010) I,(STRNAM(J,I),J=1,3),NSTRUC(I) 420 CONTINUE C C **** EVALUATE INITIAL CONDITIONS. C 430 DO 440 I=1,N2 S(I)=0. !WB storage at start of time increment for element I is equal to 0 440 FLINS(I)=0. !WB infiltration into the element is equal to 0 C C **** CONVERT SOIL CONSTANTS. C DO 450 I=1,ISR !WB do from 1 to # of soil types !RZ URBAN: IF (URBSOIL(I).EQ.1) GO TO 450 !RZ if the soil type is flagged as urban, skip calculations and go to end of loop TP(I)=TP(I)*CU1*DF(I) !WB porosity = same * conv * depth of soil horizon TP1(I)=TP(I) * A(I)=CU*A(I)*(DT/TP(I))**P(I) GWC(I)=(1.-FCAP(I))*TP(I)/DT !WB volume of air filled pore space at field capacity for soil i 450 CONTINUE C C **** INITIALIZE VALUES SPECIFIC TO INDIVIDUAL ELEMENTS. C Y=1./X !WB y = the inverse of the # of overland flow cells? DO 460 I=1,N K=2 IS=SOIL(I)/256 IC=MOD(SUR(I),256) !RZ URBAN::If the cell is urban, no airfilled pore space/area for infiltration IF (URB(I).EQ.1) THEN PIV(I)=0.0 GO TO 460 END IF PIV(I)=(1.-ASM(IS))*TP(IS)/DT 460 CONTINUE C C **** CONTINUE FOR SURFACE INITIAL CONDITION. C C CC....CALCULATION OF COEFFICIENTS FOR YALINS EQUATION........ C DO 505 IC=1,NPART CY1(IC)=EQSDIA(IC)*VISCOS !WB CY1 = equiv sand diameter of particle * kinematic viscosity of water CY2(IC)=1.65*AGRAV*EQSDIA(IC) !WB CY2 = 1.65 * acceleration due to gravity * equiv sand diam CY4(IC)=2.65*EQSDIA(IC)*SWH2O !WB CY4 = 2.65 * equiv sand diam * spec wght of water 505 CONTINUE SGD2=DSQRT(AGRAV*.5) !WB SGD2 = sqrt(accel due to gravity * 0.5) DO 506 IC=1,N K=MOD(SUR(IC),256) !WB K = surface type of element - INT(same / 256) * 256 !rz =cover type VS(IC)=SGD2*DSQRT(SL(IC)*DT/DX2) !WB VS = SGD2*sqrt(slope*time increment / area of cell) 506 CONTINUE IF(N2.EQ.N) GO TO 508 !WB if there are no channels, go to 508 DO 507 IC=N1,N2 VS(IC)=SGD2*DSQRT(SL(IC)*DT/(DX*CWID(IC))) !WB VS = SGD2 * sqrt (slope * time increment / (cell width * chan width)) 507 CONTINUE 508 CONTINUE !RZ THE FOLLOWING SUBROUTINE WAS CREATED PER DR. THEO DILLAHA'S ORDERS TO !RZ TRACK CHANGES IN ANSWERS OF THE INPUT PARAMETERS DUE TO SOME CONCERN THAT !RZ THE PROGRAM WAS CHANGING THE INPUT PARAMETERS DURING EXECUTION ! CALL CHCKDT(UNITS,PR,NRG,XDATE,SIMDUR,IG,NDT,DT,NFI,SF,ISR, ! &DF1,KOPT,SK,DC,GRF,IFERT,NCH,ICR,CROP,NOOFCHAN,DX,ITEMP,RN,NEXP, ! &ITEMPC,DAYBEG,YERBEG,WID) RETURN C C **** ERROR MESSAGES. C 510 WRITE (2,930) STOP 520 WRITE (2,840) STOP 530 WRITE (2,860) STOP 540 WRITE (2,850) STOP 550 WRITE (2,870) STOP 560 WRITE (2,890) J STOP 570 WRITE (2,900) NRG,J STOP 580 WRITE (2,910) TEST STOP 590 WRITE (2,970) ROUGH(I),CROP(I,1),CROP(I,2) STOP C C **** FORMATS. C 600 FORMAT (1X,'RAIN DATA MISSING FOR GAGE ',A2,12H, AT ELEMENT,I4,1H 1,,I4,7H: GAGE ,A2,' DATA USED') ** NRZ 9/11/94 ** MODIFIED INPUT FORMAT TO INCLUDE MULTIPLE CHANNELS C 610 FORMAT (16X,F7.2/17X,I4,8X,I4) 609 FORMAT (16X,F7.2) 610 FORMAT (27X,I4,8X,I4,5X,I5) ** NRZ 9/11/94 !620 FORMAT (11X,2A4,6X,F3.2,6X,F3.2,5X,F3.2,4X,F4.2,4X,F5.3) 620 FORMAT (11X,2A4,6X,F5.2,6X,F4.2,5X,F4.2,4X,F6.2,4X,F5.3) !RWZ changed 10/15/01 to accomodate new Questions format ! 623 FORMAT(1X,6(F4.1,1X),3(F4.2,1X)) 623 FORMAT (1X,6(F5.1,1X),3(F4.2,1X)) !WB ADDED INTERRILL COVER FACTORS 624 FORMAT(1X,11(F4.2,1X)) 625 FORMAT(1X, I3, 1X, I3, 1X, F4.2, 1X, F6.3, 1X, F5.2, 1X, F7.1, + 1X, I3, 1X, F4.2) ! 626 FORMAT(1X,F5.1,1X,F5.3,1X,F5.2,1X,F5.2,1X,F5.2,1X,F5.3,1X,F5.3, 626 FORMAT(1X,F5.1,1X,F5.3,1X,F5.3,1X,F5.2,1X,F5.2,1X,F5.3,1X,F5.3, 11X,I2,1X,I2) 629 FORMAT (7X,8(F5.2,1X)) !WB READ IN THE NEW SEDIMENT ROUTINE VARIABLES 630 FORMAT (/1X,27HSIMULATION TIME INCREMENT =,F6.1,8H SECONDS/1X, *38HINFILTRATION CAPACITY CALCULATED EVERY,I5,8H SECONDS/1X, *22HEXPECTED RUNOFF PEAK =,F8.2,2A4,/,1X,20HNUMBER OF RAIN GAGES, *3X,'= ',I4) 640 FORMAT (I4,2PF9.1,F11.1,0PF11.2,8X,F7.2,F9.1,2PF10.1,0PF9.2) 650 FORMAT (/1X,18HCHANNEL PROPERTIES/1X,4HTYPE,3X,5HWIDTH,3X, 111HMANN N SOIL,4X,10HMANN N TOT,4X,7HIMPERM.,2X,7HPERCENT 2,/,9X,A4,32X,5HDEPTH,4X,6HARMOUR,/,(I4,F8.1,4X,F5.3,10X, 3F5.3,9X,F5.3,4X,F4.2)) !WB FORMAT STATEMENT 650 EDITED TO INCLUDE MAN. OUTPUT, IMPERM LAYER 660 FORMAT (//5X,33HRAINFALL HYETOGRAPH FOR EVENT OF ,2A4) 670 FORMAT (/5X,12HGAGE NUMBER ,A2/5X,11HTIME - MIN.,7X,15HRAINFALL RA 1TE -,2A4/(F14.1,F24.2)) C NRZ 9/5/94 C CHANGED FORMAT STATEMENT TO INCLUDE AN EXTRA 2 DIGITS FOR THE CHANNEL C NETWORK NUMBER C 680 FORMAT (2I3,I2,I3,3I4,3X,A2,1X,A2,2X,I4,I3,2I4,I6,I2,I5,I5,I5) !WB 680 FORMAT (2I3,I2,I3,I4,1X,I5,I4,3X,A2,1X,A2,2X,I4,I3,2I4,I6,I2,I5,I5 !WB &,I5) 680 FORMAT (2I3,I2,I3,I4,1X,I7,I4,3X,A2,1X,A2,2X,I4,I3,2I4,I6,I2,I5,I5 &,I5) C NRZ 9/5/94 C 681 FORMAT(3I5,I6,1X,2(I1,1X),I5,1X,I1) C *** NRZ 9/11/94 C *** MODIFY OUTPUT FOR MULTIPLE CHANNEL NETWORKS C 690 FORMAT (/,5X,11A4,/,5X,'WATERSHED CHARACTERISTICS',/,' NUMBER OF', C 1F6.2,A4,' OVERLAND FLOW ELEMENTS =',I5,/,1X,'NUMBER OF CHANNEL SEG C 2MENTS = ',I3,/,1X,'AREA OF CATCHMENT =',F8.1,A4,/,1X,'CATCHMENT SL C 3OPE: MIN =',2PF7.2,' AVE =',F7.2,' MAX =',F7.2,' PERCENT',/,1X,' C 4CHANNEL SLOPE: MIN =',F7.2,' AVE =',F7.2,' MAX =',F7.2,' PERCE C 5NT',/,1X,'PERCENT OF AREA TILED =',F6.1,' WITH A D.C. OF',0PF5.2,A C 64,'/24H',/,' MEAN ANTECEDENT SOIL MOISTURE =',2PF4.0,', FIELD CAPA C 7CITY =',F4.0,' PERCENT SATURATION',/,' GROUNDWATER RELEASE FRACTIO C 8N =',0PF7.4,/,1X,'OUTLET IS ELEMENT',I5,' AT ROW',I4,' COL',I4) 690 FORMAT (/,5X,11A4,/,5X,'WATERSHED CHARACTERISTICS',/,' NUMBER OF', 1F6.2,A4,' OVERLAND FLOW ELEMENTS =',I5,/,1X,'NUMBER OF CHANNEL SEG 2MENTS = ',I5,/,1X,'AREA OF CATCHMENT =',F8.1,A4,/,1X,'CATCHMENT SL 3OPE: MIN =',2PF7.2,' AVE =',F7.2,' MAX =',F7.2,' PERCENT',/,1X,' 4CHANNEL SLOPE: MIN =',F7.2,' AVE =',F7.2,' MAX =',F7.2,' PERCE 5NT',/,1X,'PERCENT OF AREA TILED =',F6.1,' WITH A D.C. OF',0PF5.2,A 64,'/24H',/,' MEAN ANTECEDENT SOIL MOISTURE =',2PF4.0,', FIELD CAPA 7CITY =',F4.0,' PERCENT SATURATION',/,' GROUNDWATER RELEASE FRACTIO 8N =',0PF7.4) 695 FORMAT (1X,'OUTLET ',I2,' IS ELEMENT',I5,' AT ROW',I4,' COL',I4) C *** NRZ 9/11/94 700 FORMAT (/,' SURFACE COVER/MANAGEMENT CONDITIONS',8X,'SOIL ASSOCIAT 1ION PROPERTIES',/,3X,'CROP PERCENT PERCENT N',14X,'NO. PER 2CENT KS',4X,' CONTROL ',/,9X,'PRESENT COVER',25X,'PRE 3SENT',2A4,2X,'DEPTH MM') 710 FORMAT (1X, 2a4, 2P, F6.1, F7.0, 0P, 4X, F6.3, 10X, I4, 2P, + F7.1, 2X, 0P, F7.2, 2X, F8.1) 720 FORMAT (I46,2PF7.1,2X,0PF7.2,2X,F8.1) 730 FORMAT (1X, 2A4, 2P, F6.1, F7.0, 4X, 0P, F6.3) !TMN (4/25/00) !TMN 740 FORMAT (A1,F9.0,F10.2) !TMN CHANGED TO ACCOMODATE TWO DECIMALS ON THE INTENSITY (ALSO !TMN CHANGED IN THE BREAKPOINT DATA AND TO MATCH THE FORMATTING !TMN OF THE BREAKPOINT DATA SO TAMIE CAN SLEEP AT NIGHT!!! 740 FORMAT (A1,F8.0,1X,F9.2) 750 FORMAT (//1X,15HSOIL PROPERTIES/1X,4HSOIL,2X,8HPOROSITY,2X,10HFIEL 1D CAP.,2X,22HWILT. POINT HYDRAULIC,2X,7HCONTROL,2X,10HANTECEDENT, 21X,/7X,8H(PERCENT,3X,8H(PERCENT,3X,8H(PERCENT,4X,7HCONDUC 3.,5X,4HZONE,5X,8HMOISTURE,3X,/9X,5HVOL.),6X,5HSAT.), 47X,5HSAT.),6X,2A4,3X,A4,3X,13H(PERCENT SAT)) 760 FORMAT (13X,F4.1,14X,F6.3,9X,F6.3,1X,F4.2,1X,F4.2) !WB 760 MODIFIED TO INCLUDE MANNING F.F. FOR CHANNEL SOILS,IMPERM LAYER 770 FORMAT (8H ELEMENT,I4,1H,,I4,27H FLOWS OUT OF THE WATERSHED) 780 FORMAT (18X,I4) 790 FORMAT (10X,F3.2,6X,F3.2,6X,F5.2,5X,F5.3,6X,F5.1,7X,F3.2) C *** NRZ 9/12/94 C *** ADD FORMAT LINE TO ENTER SATURATED HYDRAULIC CONDUCTIVITY 791 FORMAT (23X,I1,9X,F5.2) C *** NRZ 9/12/94 795 FORMAT (1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.2,1X,F4.1,1X,F4.1) 797 FORMAT (1X,4(F7.5,1X)) 800 FORMAT (1X,A4,52X,A4) 810 FORMAT (A4,15X,I2,25X,2A4) 820 FORMAT (A4,24X,11A4) 830 FORMAT (16X,A2) 840 FORMAT (' NUMBER OF SHED+CHAN ELEMENTS EXCEEDS,10H DIMENSION') 850 FORMAT (' RAINFALL DATA EXCEEDS DIMENSION') 860 FORMAT (' NO. OF SOILS EXCEEDS DIMENSION') 865 FORMAT (' CHANNEL SOIL ',I3,' AT CELL ',I5,' EXCEEDS DIMENSION 1 OF TOTAL SOIL TYPES') !WB ADDED IN CASE CHANNEL SOIL PROPERTIES EXCEED DIMENSION 870 FORMAT (' NO. OF CROPS EXCEEDS DIMENSION SPEC') 890 FORMAT (39HCHANNELS DISCONTINUOUS NEAR ELEMENT NO.,I5) 900 FORMAT (1X,'HYETOGRAPH DATA MISSING OR INCORRECT',24H FIRST COLU 1MN NOT 0 OR 1/I4,40H GAGES REQUESTED. BAD LINE BEGINS WITH: ,A2) 910 FORMAT ('INCORRECT INPUT SEQUENCE',36H OR HEADER CARD. CARD BEGI 1NS WITH: ,A4) 920 FORMAT (30X,I3) 930 FORMAT (' NO. OF CHANNEL TYPES EXCEEDS DIMENSION') 940 FORMAT (31X,I3) 950 FORMAT (/7H COVER /20HMANAGEMENT PRACTICES/3X,4HCROP,6X, 19HMAX. POT.,3X,7HPERCENT,2X,6HROUGH.,2X,6HROUGH. 2,2X,9HMAX. RET.,2X,/11X,12HINTERCEPTION, 33X,5HCOVER,3X,6HCOEFF.,2X,6HHEIGHT,2X,5HDEPTH,5X, 4/14X,A4,23X,A4,4X,A4) 960 FORMAT (1X,I2,1X,2A4,F7.2,2PF12.0,0PF8.2,F8.1,F10.3,F10.2) 970 FORMAT (20H ROUGHNESS COEFF. OF,F8.2,27H IS OUT OF RANGE FOR CROP: 1 ,2A4) 975 FORMAT (/,1X,4HCROP,3X,6HRANDOM,6X,6HBURIED,3X,9HMAX PLANT,3X, 16HGROWTH,3X,4HRILL,/,1X,1H#,6X,9HROUGHNESS,3X, 27HRESIDUE,2X,6HHEIGHT,6X,6HFACTOR,3X,7HSPACING,3X,/,8X,4H(MM),8X, 38H(KG/M^2),1X,3H(M),18X,8H(M/RILL)) 976 FORMAT (1X,I2,F11.2,1X,F11.2,F7.2,8X,F4.2,5X,F4.2) 977 FORMAT (/,1X,4HCROP,3X,11HMANNING'S N,3X,11HMANNING'S N,3X, 110HNO-TILLAGE,3X,7HNO-EROS,/,8X,4HSOIL,10X,5HTOTAL,9X, 24HFLAG,9X,4HFLAG) 978 FORMAT (1X,I2,5X,F5.3,9X,F5.3,8X,I2,11X,I2) 1958 FORMAT (/,1X,4HCROP,3X,9HINTERRILL,3X,9HINTERRILL,3X,9HLIVE ROOT, 13X,9HDEAD ROOT,3X,9HDEAD ROOT,/,1X,1H#,6X,9HCOVER INI,3X, 29HCOVER FIN,3X,4HMASS,8X,9HMASS INIT,3X,10HMASS FINAL) 1960 FORMAT (1X,I3,4X,F4.2,8X,F4.2,8X,F4.2,8X,F4.2,8X,F4.2) !WB ADDED 1958 AND 1960 TO PRINT THE COVER EROS PARAMETERS C *** NRZ 9/12/94 C *** MODIFY FORMAT LINE TO INCLUDE FERTILIZER FILE FLAG C 980 FORMAT (20X,I2/39X,F5.2/31X,E10.3) 980 FORMAT (20X,I2/39X,F5.2/31X,E10.3,/21X,I2,/21X,I2) C *** NRZ 9/12/94 C *** NRZ (8/29/94) C *** ADDED FORMAT STATEMENTS FOR IMPOUNDMENT DATA 981 FORMAT (/,1X,25X,I2) 982 FORMAT (1X,I7,3(1X,F6.1),2(1X,F7.1),1X,F6.1,1X,F5.3,1X,F11.3) C *** NRZ (8/29/94) 990 FORMAT (/1X,19HDRAINAGE EXPONENT =,I2/1X,22HTILE DRAINAGE COEFF. = 1,F5.2,A4,4H/24H/1X,30HGROUNDWATER RELEASE FRACTION =,E10.3) 1000 FORMAT (/3X,28HSTRUCTURAL MEASURES INCLUDED,/10X,4HTYPE,9X,6HNUMBE 1R) 1010 FORMAT (I7,2X,3A4,I6) 1020 FORMAT (1X,11HCHANNEL NO.,I5,15H AT ELEMENT NO.,I5) 1030 FORMAT (39X,I4/17X,F5.1/39X,I5/23X,F7.2) 1040 FORMAT(/20X,'PARTICLE SIZE DISTRIBUTION DATA'/) 1050 FORMAT(/36X,I2/36X,I2/) 1060 FORMAT(14X,37H NUMBER OF PARTICLE SIZE CLASSES =,I2/ *14X,37H NUMBER OF WASHLOAD CLASSES =,I2) 1070 FORMAT(1X,F15.8,F15.3,F15.7) 1080 FORMAT(3X,5HCLASS,3X,6HDIA,MM,7X,9HEQSAND,MM,10X,2HSG,3X, *14HFALL VELOCITY,,A4,2H/S) 1090 FORMAT(5X,I1,4X,F6.3,2F15.3,F15.7) 1110 FORMAT(1X,8F6.3) 1100 FORMAT(1X,47HPARTICLE SIZE DISTRIBUTION OF SOILS AS DETACHED/ *2X,52HCLASS 1 2 3 4 5 6 7 8) 1120 FORMAT(1X,4HSOIL,I2,8F6.3) 1111 FORMAT(1X,9F8.4) 1666 FORMAT(1X,35X,I3,1X,I4) ! TMN 1667 FORMAT(1X,28X,I4) ! CHANGED FROM I4 TO I8 TO ACCOMODATE ! TMN LONGER RUNS 1667 FORMAT(1X,28X,I8) 1700 FORMAT(///,30X,22H**** DAILY OUTPUT ****,///) 1710 FORMAT(2X,4HYEAR,1X,3HJUL,3X,8HRAINFALL,2X,6HRUNOFF,2X,8HSEDIMENT &,2X,8H NITRATE,2X,8HDIS. NH4,2X,8H SED.NH4,2X,8HSED.ORGN/ &,7X,3HDAY,6X,2HMM,7X,2HMM,6X,5HKG/HA,5X,4HMG/L,5X,4HMG/L,7X &,4HG/HA,5X,4HG/HA,/,56X,6HSED. P,6X,6HSOL. P,/,58X,4HG/HA,7X, &4HMG/L) C *** NRZ 7/29/95 C *** MODIFIED FORMAT LINE TO INCLUDE 7 ROTATION END DATES PER LINE C1800 FORMAT(1X,I2,1X,5(I2,1X,I7,1X)/4X,5(I2,1X,I7,1X)/4X,5(I2,1X,I7,1X) C & /4X,5(I2,1X,I7,1X)) !TMN MODIFIED FORMAT FOR ROTATION END DATES TO ALLOW FOR 301 END DATES !TMN WITH A TOTAL OF 29 LINES PER ROTATION ! 1800 FORMAT(1X,I2,1X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) ! & /4X,7(I2,1X,I7,1X)) 1800 FORMAT(1X,I2,1X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X)/4X,7(I2,1X,I7,1X) & /4X,7(I2,1X,I7,1X)) 1950 FORMAT (1X,'THE FRICTION FACTOR FOR CROP',F6.3,' EXCEEDS THE ' 1,/,' COMBINED FRICTION FACTOR:',F6.3,' FOR CROP #: ',I3 2,/,' PLEASE CHANGE THIS.') !RZ changed 'soil' to 'crop' in above error message because soil is wrong 1952 FORMAT ('THE NOTILL FLAG IS NOT A 0 OR A 1. PLEASE CHECK' 1,/,'THE MAIN INPUT FILE. THE PROGRAM HAS STOPPED.') 1954 FORMAT ( 'THE NO EROSION FLAG IS NOT A 0 OR A 1. PLEASE' 1,/,' CHECK THE MAIN INPUT FILE. THE PROGRAM HAS STOPPED.') 1956 FORMAT ('THE BURIED RESIDUE FACTOR APPEARS TO BE INPUT 1IMPROPERLY' 2,/,' AS ITS VALUE EXCEEDS 1 KG/M2, OR 10,000 KG/HA.') 1962 FORMAT ('THE DEAD ROOT MASS AT THE END OF THE CROP/COVER: ', 1F6.3,/,' EXCEEDS THE INITIAL DEAD ROOT MASS FOR THE 2CROP/COVER: ',F6.3,' FOR COVER # ', I3,/,' AND THE PROGRAM 3 HAS TERMINATED') C END SUBROUTINE STRUCT (I,J,RFL,IEL,JMAX,NPAR,NMAX,STRUC,NSTRUC,I 1STRUC,X,DX,WID,SSII,SSI,PIV,CN,CWID,CHAN,CONST,SL,II,SCMIN,SCMAX,S 2CBAR,ANG,IELC,NPAR2,CALLBMP,HASOPENED) IMPLICIT DOUBLE PRECISION A-H,O-Z C C ****** SUBROUTINE TO ADJUST PARAMETERS TO REFLECT STRUCTURAL PRACTICES C ****** INSTALLED WITHIN AN ELEMENT. C DIMENSION IEL(3,JMAX,NPAR2), NSTRUC(ISTRUC), WID(10), CN(10) DIMENSION IELC(3,JMAX,2) DIMENSION ADUMMY(101) DIMENSION CALLBMP(35000) INTEGER CHAN,PRACT,CALLBMP,BMPLOC,SIMDUR,HASOPENED LOGICAL STRUC CHARACTER*2 IELC COMMON /BMP2/ PONDAREA(300),NRO(300),H2ODEPTH(300), 6ORAREA(300),WEIRVOL(300),ORVOL(300),ORTOP(300), 7MAXFLOW(300),SOLP(300),SOLNH4(300),SOLNO3(300), 8LOST(300),WLOST(300),ORBOT(300),TIPE(300), 9PIPEN(300),PIPED(300),PIPEL(300),RISD(300),PIPEAREA(300), 1RISH(300) INTEGER TIPE COMMON /BMP3/ POND(35000),STREAM(300),SUB(300) INTEGER POND,SUB COMMON /CFLOW2/NR(35000),NC(35000),S(35000) C C **** SWITCH TO APPROPRIATE HANDLER FOR EACH STRUCTURAL TYPE. C PRACT=IEL(2,J,9) IF (PRACT.GT.ISTRUC.OR.PRACT.LT.0) GO TO 90 STRUC=.TRUE. NSTRUC(PRACT)=NSTRUC(PRACT)+1 GO TO (10,60,70,80), PRACT C C **** HANDLE PONDS AND TILE-OUTLET TERRACES BY USING A TRAP EFFICIENCY C **** APPROACH, FOR BOTH SEDIMENT AND WATER. C C **** CASE 1 IS FOR A PTO. C 10 TRAP=.90 C C **** CHECK FOR A POSSIBLE SHADOW CHANNEL ELEMENT. C 20 IF (CHAN.EQ.0) GO TO 40 C C **** IT'S A CHANNEL ELEMENT, DOES IT REQUIRE DIAGONAL FLOW? C IF (ANG.LT..3926991.OR.ANG.GT.1.178097) GO TO 40 C C **** FLOW IS DIAGONAL, CHANGE DESTINATION ELEMENT NUMBERS. C IF (NR(I).LT.I) GO TO 30 NR(I)=NC(I)+1 NC(I)=NC(I)+1 GO TO 40 30 NR(I)=NC(I)-1 NC(I)=NC(I)-1 C C **** THE PREDOMINANT OVERLAND DIRECTION IS MAINTAINED AND THAT C **** ELEMENT WILL RECEIVE THE UNTRAPPED FLOW AND SEDIMENT. C !RZ basically, you determine which is the predominant flow direction (RFL lt/gt 0.5) !RZ if the row is the predominant direction (50), then set the row flow to 1-trap !RZ which is all the water that escapes from the BMP, NR remains the same, and NC becomes !RZ a dummy cell to capture the trapped water, sediment, etc. !RZ if the column is the predominant direction (40), then set the row flow to trap (leaving !RZ column flow as 1-trap) and channel all the row flow (aka flow trapped by BMP) to a dummy !RZ row cell. All non trapped flow is channeled to the receiving column cell. 40 IF (RFL.GT..5) GO TO 50 RFL=TRAP NR(I)=NMAX+1+PRACT RETURN 50 RFL=1.-TRAP NC(I)=NMAX+1+PRACT RETURN C C **** PONDS ARE SIMILAR TO PTO'S, BUT HAVE A HIGHER TRAP EFFICIENCY. C 60 TRAP=.95 GO TO 20 C C **** GRASSED WATERWAYS DIRECTLY AFFECT ONLY THE VEGETAGED AREA OF C **** THE ELEMENT IN WHICH THEY ARE LOCATED, BUT THEY MUST ALSO ASSURE C **** THAT THIS ELEMENT HAS A SHADOW CHANNEL ELEMENT. C 70 IF (CHAN.NE.0) GO TO 80 C C **** CURRENT ELEMENT DOES NOT HAVE A SHADOW CHANNEL ELEMENT, MAKE ONE. C CHAN=IEL(2,J,11) IF (CHAN.EQ.0) CHAN=1 II=II+1 CWID=WID(CHAN) PIV=CONST/CN(CHAN)/X*(DX/CWID/X)**.6667*DSQRT(SSI) SSII=SSI IF (SSI.LT.SCMIN) SCMIN=SSI IF (SSI.GT.SCMAX) SCMAX=SSI SCBAR=SCBAR+SSI C C **** NOW ACCOUNT FOR VEGETATED AREA BY REDUCING THE SEDIMENT C **** DETACHMENT BY FLOW FOR THIS ELEMENT BY AN AMOUNT PROPORTIONAL C **** TO THE VEGETATED AREA. SINCE FLOW DETACHMENT IS DIRECTLY C **** PROPORTIONAL TO THE OVERLAND SLOPE, ADJUST THAT PARAMETER. C C **** FIELD BORDERS HAVE A SIMILAR EFFECT TO THE VEGETATED AREA C **** OF GRASSED WATERWAYS. C 80 TRAP=DBLE(IEL(2,J,10))/DX IF (TRAP.GT..5) TRAP=.5 SL=SL*(1.-TRAP) RETURN C C **** CHECK TO SEE IF IT'S A MANAGEMENT PRACTICE BEFORE SPOUTING OFF. C 90 IF (PRACT.GT.10.AND.PRACT.LT.13) RETURN IF (PRACT.GT.6.AND.PRACT.LT.10) THEN BMPLOC=1 IDUMMY=0 DUMMY=0. CALL BMPS(BMPLOC,IDUMMY,IDUMMY,ADUMMY,DUMMY,DUMMY,DUMMY,DUMMY 1 ,IDUMMY,DUMMY,IDUMMY,IDUMMY,IDUMMY,IDUMMY,IDUMMY,IDUMMY,DUMMY, 2 DUMMY,HASOPENED,CALLBMP,IDUMMY) RETURN END IF !RZ IF THE PRACTICE IS 7,8,9 THEN IT IS AN URBAN PRACTICE, RESERVE FOR FUTURE USE !RZ The subroutine call reads the bmp input file and does the preliminary calculations !RZ for later in the program. Dummy variables are used for most of the parameters in the !RZ call because no outside data is needed for the initialization section of the bmp subroutine. WRITE (2,100) IEL(2,J,9),IEL(2,J,1),J RETURN C 100 FORMAT (14H PRACTICE NO.,I3,7H IN ROW,I4,5H, COL,I4,20H ILLEGAL A 1ND IGNORED) C END SUBROUTINE DRAIN (DR,DC,DIN,N,N1,N2,STD,TIAL,RFL,NR,NC) IMPLICIT DOUBLE PRECISION A-H,O-Z C C ****** SUBROUTINE FOR SUBSURFACE DRAINAGE. C DIMENSION DR(35000), DIN(35000), RFL(35000) INTEGER NR(35000),NC(35000),TIAL(35000) C C **** SET ALL CHANNEL INFLOWS TO ZERO. C DO 10 I=N1,N2 10 DIN(I)=0. STD=0. C C **** ROUTE DRAINAGE FROM TILES. C DO 50 I=1,N DRANE=0. IF (TIAL(I).LT.256) GO TO 40 !rwz no tiles IF (DR(I).GT.DC) GO TO 20 !rwz amount draining > drainage coefficent DRANE=DR(I) !does this if amount draining all goes into drain GO TO 30 20 DRANE=DC !amount drained limited by drainage coefficient 30 STD=STD+DRANE 40 DRANE=DRANE+DIN(I) DD=RFL(I)*DRANE J=NR(I) K=NC(I) DIN(J)=DIN(J)+DD DIN(K)=DIN(K)-DD+DRANE 50 DIN(I)=0. RETURN C END FUNCTION FILT(PIV,FCAP1,GWC,DR,S,R,CU2,ROUGH,HU,NEXP,ASMPER, & KE,PSIF,PHIC,T,CU,LF,KS,K,kk,M,CUMIN1,rbit0,testi,timpon, & TPON,FILTS,DT,CU1,TP1,AZRAT) IMPLICIT DOUBLE PRECISION A-H,O-Z DOUBLE PRECISION NS,KE,KS,LF C C **** POTENTIAL INFILTRATION CAPACITY -- WHOLE SURFACE COVERED. C IF (T.LE.O.) GOTO 50 C C **** UNSATURATED INFILTRATION ZONE. C ************************************ ********************************* ******EFFECTIVE MATRIX POTENTIAL NS=PHIC*(1.0-ASMPER)*PSIF *************************************** **DETERMINE THE CUMULATIVE INFILTRATION USING THE NEWTON ITERATION **TECHNIQUE **KE*T=F-NS*LN(1+F/NS); G=(F-KE*T)-NS*LN((NS+F)/NS) ** DG/DF= 1-NS/(F+NS)=F/F+NS ** F2=F1-G1/(DG/DF1) * if(m.eq.503)write(6,*) filts/cu * if(R.lt.0.) stop if (t.eq.0.) then fmax=r testi=0 test1=10 goto 2 endif T2=T rbit=r/cu if ((r.eq.0.).and.(testi.eq.1).and.(s.lt.0)) then fmax=filts testi=0 goto 2 endif if((ke.gt.rbit).and.(testi.eq.1).and.(s.gt.0)) then testi=1 goto 8 else if((ke.gt.rbit).and.(testi.eq.1).and.(s.lt.0)) then testi=0 goto 2 endif endif if(rbit0.eq.r) goto 111 if((ke.le.rbit).and.(testi.eq.1)) then testi=1 test1=13 goto 8 endif if((ke.gt.rbit).and.(testi.eq.0)) then fmax=filts if(r.gt.0.)fmax=r testi=0 goto 2 endif if ((r.eq.0.).and.(testi.eq.1).and.(s.lt.0)) then fmax=filts testi=0 goto 2 endif cumpon=ns/((rbit/ke)-1.) if((cumpon-cumin1).lt.0.) then timpon=t2 Tpon=60*((cumin1)-NS*DLOG(1.0+(cumin1)/NS))/KE goto 112 endif timpon=(cumpon-cumin1)*60./rbit+t2 Tpon=60*((cumpon)-NS*DLOG(1.0+(cumpon)/NS))/KE test1=15 goto 112 111 continue if(testi.eq.1) goto 8 if ((ke.ge.rbit).and.(testi.eq.0.)) then fmax=filts if(r.gt.0) fmax=r testi=0. timpon=0. tpon=0. test1=16 goto 2 endif 112 if(t2.lt.timpon) then fmax=r testi=0 * test1=17 goto 2 endif 8 t1=t2-timpon+tpon if(t1.lt.0.) then fmax=filts goto 2 endif testi=1. 77 if(cumin1.gt.0) then cumf=cumin1 else cumf=0.1 endif 88 ZU1=(T1/60.)*KE-(CUMF-NS*DLOG(1.0+CUMF/NS)) DEL=CUMF/(NS+CUMF) TEST=ZU1/DEL XX=CUMF+TEST IF(ABS(TEST).GT.0.000001) THEN CUMF=XX IF ((CUMF/NS).LT.-1.) THEN CUMINF=0.01 WRITE(*,*) 'The infiltration calc. cannot converge on a solution.' WRITE(*,*) 'Cum. inf. has been set to 0.01. If this is not okay,' WRITE(*,*) 'vary the soil input parameters until this message no' WRITE(*,*) 'longer appears. Soil Porosity seems to be important.' WRITE(2,*) 'The infiltration calc. cannot converge on a solution.' WRITE(2,*) 'Cum. inf. has been set to 0.01. If this is not okay,' WRITE(2,*) 'vary the soil input parameters until this message no' WRITE(2,*) 'longer appears. Soil Porosity seems to be important.' PAUSE GO TO 7 END IF GOTO 88 ENDIF CUMINF=CUMF 7 CONTINUE FMAX=KE*(1+NS/CUMINF)*CU ZXA=FMAX/CU FILT=FMAX * 2 rbit0 = rbit 2 FILT=FMAX * if (m.eq.76) write(5,888)ke,r/cu,t,timpon,tpon,fmax/cu,testi, * & cumin1,cumpon,filts/cu,s/cu,t2 888 format(12(f10.4,1x),f3.1,5(f10.4,1x)) rbit0=r cumpon=0. test1=0. IF (PIV) 30,40,10 10 IF (PIV.LT.GWC) GO TO 20 DR=0. RETURN ******************************** 20 CONTINUE RKFC=KS*AZRAT*(1-PIV*DT/TP1)**(-2.655/DLOG10(FCAP1)) TI=(((1-PIV*DT/TP1)-FCAP1)*TP1/CU1)/RKFC * computing drainage for one hour ZFAY=1./TI IF(ZFAY.GT.75.) TI=1./75. DR=(((1-PIV*DT/TP1)-FCAP1)*TP1/CU1)*(1.-DEXP(-1/(TI)))*CU ASMFI=(1-PIV*DT/TP1)*TP1/CU1 RETURN ******************************** C C **** INFILTRATION ZONE SATURATED. C 30 PIV=0. 40 RKFC=KS*AZRAT*(1-PIV*DT/TP1)**(-2.655/DLOG10(FCAP1)) TI=(((1-PIV*DT/TP1)-FCAP1)*TP1/CU1)/RKFC ZFAY=1./TI IF(ZFAY.GT.75.) TI=1./75. DR=(((1-PIV*DT/TP1)-FCAP1)*TP1/CU1)*(1.-DEXP(-1./(TI)))*CU FMAX=DR FILT=FMAX testi=1 RETURN C END FUNCTION RAIN(RATE,PIT,PER) IMPLICIT DOUBLE PRECISION A-H,O-Z C C ****** DETERMINATION OF NET RAINFALL RATE. C IF (RATE.EQ.0.) GO TO 50 IF (PIT) 40,50,10 !WB IF (PIT) < = > 0, GOTO 40, 50, 10 10 RIT=PER*RATE !RZ RIT=rainfall rate*percent vegetative cover; i.e., RIT=rainfall rate on plants IF (RIT-PIT) 20,30,30 !WB IF (RIT-PIT) < = > 0, GOTO 20, 30, 30 !RZ i.e.,if interception > rainfall, =rainfall, or # overland flow el's, THIS ORIGINALLY RESET !WB THE FLOW AND RAINFALL DETACHMENT EQUAL TO 0. NOW, THE RAIN- !WB FALL DETACHMENT IS RESET TO 0, WHILE FLOW DETACHMENT IS CALCULATED !WB FOR CHANNEL CELLS. C CC....CALCULATE RAINFALL DETACHMENT & POTENTIAL FLOW DETACHMENT.... C !WB ************* NEW SEDIMENT DETACHMENT ROUTINE ***************** !WB ********************* flow detachment ************************* JK=MOD(SUR(M),256) !WB jk extracts the crop descriptor #=cover type IF (M.GT.N) GO TO 9400 !WB THIS SKIPS THE RILL WIDTH CALCULATION IF THE CELL IS A CHANNEL CELL. IF (RILLSPC(JK).EQ.0) RILLSPC(JK)=1. !WB ADDED 1/6/99 AS A DEFAULT. NORILLS=DX/RILLSPC(JK) !WB norills=the number of rills per cell. QEFF=Q(M)/(NORILLS) !WB effective flow = total flow on cell / # of rills per cell, !WB this should be flow per rill contributing area (the rill plus !WB the interrill area that contributes flow to the rill) RILLWID=1.13*QEFF**0.303 !WB rillwid=rill width, see 1995 WEPP documentation, eqn 10.7.1 IF (RILLWID.GT.MAXWID) THEN !WB THE MAX WIDTH IS SET EQUAL TO A VERY SMALL # RIGHT AFTER !WB A CROPPING ROTATION CHANGES (INDICATING OBLITERATION OF RILLS) !WB AND CONTINUES TO WIDEN DURING THE CROP GROWTH PERIOD. MAXWID=RILLWID !WB IF THE CURRENT RILLWID EXCEEDS THE MAXWID, THEN SET MAX = CURRENT ELSE RILLWID=MAXWID !WB IF A PREVIOUS WIDTH IS GREATER, THEN SET CURRENT = MAX WIDTH ENDIF IF (RILLWID.GT.RILLSPC(JK)) THEN !WB THIS IS A FLAG TO INDICATE THAT THE RILL WIDTH OF AN O.F. CELL IS !WB GREATER THAN RILL SPACING (I.E.-MORE !WB RILL THAN YOU HAVE SPACE.) NORILLS=NORILLS/2 RILLSPC(JK)=RILLSPC(JK)*2 END IF IF (RILLWID.GT.RILLSPC(JK)) THEN WRITE (2,1000) M,RILLWID,RILLSPC(JK) WRITE (*,1000) M,RILLWID,RILLSPC(JK) PAUSE ENDIF 9400 CONTINUE IF (M.GT.N) THEN QEFF=Q(M) RILLWID=XZW+WIDINC(M) JK=21 MNSOIL(JK)=MNCHNSL(M) MNTOT(JK)=MNCHNTOT(M) NORILLS=1. IF (MNSOIL(JK).GT.MNTOT(JK)) THEN WRITE (2,1002) WRITE (*,1002) STOP ENDIF !WB IF THE CELL IS A CHANNEL CELL, THEN SET THE QEFF EQUAL TO FLOW !WB RATE, AND RILLWID=CWID (PASSED AS XZW IN THE SUBROUTINE CALL), !WB IF THE CELL IS DESIGNATED NOEROS THEN SET THE WIDTH INCREASE = 0 !WB THEN SET JK=21, WHICH IS THE LAST POSITION !WB IN THE ARRAY MNSOIL, AND USE THIS POSITION TO HOLD THE FRICTION !WB FACTOR FOR EACH CHANNEL CELL. SAME GOES FOR MNTOT. FINALLY, THERE'S !WB AN ERROR STATEMENT IF MNSOIL EXCEEDS MNTOT. ENDIF DIFF=1. FLDEPOLD=1.0 FLOWDEP=FLOWDEPOLD(M) ! FLOWDEP=1.0 CNTER=0 CNTFLAG=100 DEPINIT=0 DWSOIL=(MNTOT(JK)*MNTOT(JK)*8*9.80665)/(HYDRADOLD(M)**0.33333333) IDAYOLD=0 IF (DWSOIL.GT.10) THEN DWSOIL=10 ENDIF IF (DWSOIL.LT.0.1) THEN DWSOIL=0.1 ENDIF !WB SET THE INITIAL CONDITIONS FOR THE ITERATION. THE ITERATION IS !WB THE NEWTON-RAPHSON METHOD FOR MULTIPLE ROOTS PER 'NUMERICAL !WB METHODS FOR ENGINEERS, 2ND ED.' BY CHAPRA AND CANALE, 1988, !WB MC-GRAW HILL. !WB THE EQUATION IS THE DARCY-WEISBACH FRICTION FACTOR EQN, SOLVED !WB FOR THE HYD RAD, AND THEN SET EQUAL TO THE DEFN OF HYD RAD AND !WB SOLVED FOR FLOW DEPTH. AN INITIAL GUESS OF DWSOIL IS REQUIRED. !WB IT HAS BEEN ARBITRARILY SET TO = 0.1. IT IS THEN CALCULATED !WB BASED ON THE MANNING'S N AND HYD RADIUS. IF (QEFF.LT.0.00001) THEN QEFF=0 FLOWDEP=0 GOTO 9005 ENDIF !WB THIS WAS ADDED 1/5/99 AFTER SOME DIFFICULTIES IN THE SOLUTION !WB TECHNIQUE IN SOLVING FLOWDEPTH FOR CHANNELS WITH VERY LOW QEFF !WB (LESS THAN 1e-8). THE EXACT PROBLEM WAS UNDETERMINED, HOWEVER !WB THE SOLUTION TECHNIQUE WAS PROVEN FOR THE SAME PARAMETER VALUES !WB THAT CAUSED THE ERROR USING A SPREADSHEET WITH THE SAME ITERATION, !WB SO THE ERROR IS LIKELY DUE TO ROUNDING. DIFFLIMIT=0.00001 9001 DO WHILE ((DIFF.GT.0.00001).OR.(FLOWDEP.LT.0)) !WB DO THIS WHILE THE DIFFERENCE IN FLOW DEPTH B/T THIS CALC AND !WB THE PREVIOUS CALCULATION IS GT 0.0001, AND WHILE THE FLOWDEPTH !WB IS NEGATIVE. THE SECOND PART IS NECESSARY B/C THIS TECHNIQUE WILL !WB SOMETIMES PRODUCE NEGATIVE VALUES IN THE FIRST FEW ITERATIONS. IF (CNTER.EQ.0) THEN !WB THIS SECTION SAVES THE INITIAL VALUES IN CASE THE ITERATION DOESN'T !WB CONVERGE. IF AFTER 100,200,300,500 ITERATIONS W/O CONVERGENCE, THE !WB ITERATION IS RETRIED WITH DIFFERENT INITIAL CONDITIONS. IF, AFTER !WB 10,000 ITERATIONS, THERE IS NO CONVERGENCE, THE PROGRAM CALLS AN !WB ERROR MESSAGE AND STOPS. FLDEP=FLOWDEP RLWID=RILLWID DIF=DIFF FLDOLD=FLDEPOLD ENDIF FOFD=((FLOWDEP**3)*(RILLWID**3)*8*9.80665*SL(M))-(DWSOIL 1*(QEFF**2)*2*FLOWDEP)-(DWSOIL*(QEFF**2)*RILLWID) !WB FOFD=f(FLOWDEP) FPOFD=(3*(FLOWDEP**2)*(RILLWID**3)*8*9.80665*SL(M))-(DWSOIL* 1(QEFF**2)*2) !WB FPOFD=f'(FLOWDEP) FDPOFD=(6*FLOWDEP*(RILLWID**3)*8*9.80665*SL(M)) !WB FDPOFD=f''(FLOWDEP) FLOWDEP=FLDEPOLD-((FOFD*FPOFD)/((FPOFD**2)-FOFD*FDPOFD)) !WB Xi+1=Xi-((f(D)*f'(D))/(f'(D)^2-f(D)*f''(D))) WHERE D = FLOWDEPTH DIFF=ABS(FLOWDEP-FLDEPOLD) !WB DIFF=TEST VARIABLE FOR THE LOOP. FLDEPOLD=FLOWDEP !WB SET THE FLDEPOLD=FLOWDEP FOR THIS CALCULATION. CNTER=CNTER+1 IF (CNTER.GT.10000) THEN !WB THIS DISPLAYS AN ERROR MESSAGE IF, AFTER 10000 ITERATIONS, !WB THE EQUATION DOES NOT CONVERGE. ! FLOWDEP=FLOWDEPOLD(M) FLOWDEP = ABS(DEPTHINC(M)) DIFF=0.0 IF (LDAY.NE.IDAYOLD) THEN IDAYOLD=LDAY WRITE(2,*) M,LDAY,FLDEPOLD END IF ! WRITE (2,1004) M,QEFF,RILLWID,SL(M),DWSOIL,FLDEPOLD ! WRITE (*,1004) M,QEFF,RILLWID,SL(M),DWSOIL,FLDEPOLD ! STOP ENDIF IF (CNTER.EQ.CNTFLAG) THEN !WB THIS RESTARTS THE CALCULATION WITH DIFFERENT INITIAL CONDITIONS DEPINIT=DEPINIT+0.10 DIFFLIMIT=DIFFLIMIT+0.0000999 ! FLOWDEP=10.-DEPINIT ! FLOWDEP=(QEFF*MNTOT(JK)/(DSQRT(SL(M))*RLWID))**(3./5.)-DEPINIT FLOWDEP=DEPINIT RILLWID=RLWID DIFF=DIF FLDEPOLD=DEPINIT CNTFLAG=CNTFLAG+100 GO TO 9001 ENDIF END DO FLOWDEPOLD(M)=FLOWDEP !RZ THIS WAS INSERTED 2/06/01. NOW THE SUBROUTINE WILL USE FLOWDEP AS !RZ AN INITIAL GUESS FOR THE NEXT TIME STEP. THIS WILL HELP NEWTON'S METHOD !RZ TO CONVERGE MORE QUICKLY THAN BEFORE. IF (FLOWDEP.LT.0) THEN !WB FLOWDEPTH CALCULATION ERROR MESSAGE, WHICH IS LIKELY DUE TO PROGRAM !WB ERROR, SUCH AS AN ARRAY THAT HAS "OVER-FLOW'ED". WRITE (2,1006) M,FOFD,FPOFD,FDPOFD,FLOWDEP,FLDEPOLD,RILLWID,QEFF, 1SL(M),DWSOIL,DIFF WRITE (*,1006) M,FOFD,FPOFD,FDPOFD,FLOWDEP,FLDEPOLD,RILLWID,QEFF, 1SL(M),DWSOIL,DIFF STOP ENDIF 9005 CONTINUE 9006 HYDRAD=(FLOWDEP*RILLWID)/(2*FLOWDEP+RILLWID) !WB hydrad= hydraulic radius HYDRADOLD(M)=HYDRAD !WB SAVE THE HYDRAD FOR THE DWSOIL CALC THE NEXT TIME STEP IF (HYDRADOLD(M).EQ.0) HYDRADOLD(M)=0.1 !WB IF QEFF = 0 , HYDRAD = 0, & DWSOIL IS DIV BY 0, SO RESET HYDRADOLD=0.1 TAUEFF=9806.65*SL(M)*HYDRAD*((MNSOIL(JK)*MNSOIL(JK)) 1/(MNTOT(JK)*MNTOT(JK))) !WB taueff = effective shear stress,9806.65 (kg*m-2*s-2) = !WB specific weight of water !WB sl(M) is the element slope in m/m !WB degrees. MNSOIL is the manning's n friction factor for !WB the bare soil, while MNTOT includes the factor for cover. IF (TAUEFF.GT.TAUCADJ(M)) THEN DCAP=KRADJ(M)*(TAUEFF-TAUCADJ(M))*(NORILLS*RILLWID*DX) !WB THE ABOVE LINE SAYS THAT RILL DETACHMENT EQUALS THE DETACHMENT !WB CAPACITY TIMES THE RILL CONTRIBUTING AREA !RZ Detachment CAPacity - see equation 16 in Wes Byne's thesis IF (M.GT.N) THEN DCAP=DCAP*(1-ARMOUR(M)) !WB DETACHMENT CAPACITY IN A CHANNEL IS EQUAL TO DETACHMENT !WB CAPACITY TIMES THE AMOUNT OF THE CHANNEL SOIL THAT IS !WB ERODIBLE (ARMOUR IS THE NONERODIBLE PERCENTAGE) DOWNRATE(M)=(KRADJ(M)*(TAUEFF-TAUCADJ(M))/BULKDENS(KK))* 1(1-ARMOUR(M)) !WB DOWNRATE=RATE OF EROSION OF THE CHANNEL BOTTOM (M/S) DEPRATE(M)=(DEPPREV(M)/BULKDENS(KK))/XZW !WB THIS IS THE DEPOSITION RATE AT THE PREVIOUS TIME STEP, USED !WB TO ADJUST THE DEPTHINC VAR FOR DEPOSITION. THE CALCULATION IS: !WB ((KG/S)/(KG/M^3)) / M WIDTH, ASSUMED 1 METER LENGTH ALONG !WB CHANNEL BOTTOM, YIELDS UNITS M/S DEPTHINC(M)=DEPTHINC(M)+(DOWNRATE(M)*DT)-(DEPRATE(M)*DT) !WB DEPTHINC=DEPTH THAT THE CHANNEL BOTTOM HAS ERODED (METERS) IF (DEPTHINC(M).GT.ROCKBOT(M)) DEPTHINC(M)=ROCKBOT(M) !WB IF THE ERODED DEPTH IS GREATER THAN THE NONERODIBLE BOUNDARY, !WB THEN BOTTOM EROSION IS RESET EQUAL TO THE NONERODIBLE DEPTH, !WB THIS ALLOWS FOR DEPOSITION TO LESSEN THE ERODED DEPTH !WB "INCREMENT". IF DEPTHINC > NONERODIBLE DEPTH, EROSION !WB SWITCHES TO THE WALLS DEPRATE(M)=0. !WB THIS MAKES SURE THAT AN 'OLD' VALUE OF DEPOSITION DOESN'T !WB AFFECT CALCULATIONS IF (DEPTHINC(M).GE.ROCKBOT(M)) THEN !WB IF THE ERODED DEPTH IS G.E. THE DISTANCE TO AN IMPERMEABLE LAYER WIDINC(M)=WIDINC(M)+DOWNRATE(M)*DT !WB WIDINC=WIDTH THAT THE CHANNEL HAS ERODED. NOTE THAT THE EROSION !WB RATE IS THE SAME FOR DOWNWARD MOVEMENT AS FOR LATERAL MOVEMENT. DCAP=KRADJ(M)*(TAUEFF-TAUCADJ(M))*(2*FLOWDEP*DX) !WB BECAUSE THE CHANNEL BOTTOM IS CONSIDERED UNERODIBLE, DETACHMENT !WB CAPACITY IS CALCULATED ALONG THE CHANNEL WALLS,AND NORILLS=1. !WB RATE IS (KG/S) DCAP=DCAP*(1-ARMOUR(M)) !WB DETACHMENT CAPACITY TIMES THE ERODIBLE FRACTION OF SOIL (THIS !WB WAS INCLUDED FOR WALL EROSION TO SIMULATE LOWERED ERODIBILITY !WB OF CHANNEL SOIL) ENDIF ENDIF ELSE DCAP=0. !WB IF THE EFFECTIVE SHEAR STRESS DOESN'T EXCEED THE BASELINE, THERE !WB IS NO RILL DETACHMENT. ENDIF DO IC=1,NPART IF ((SST(M,IC).GT.TF(IC)).OR.((SST(M,IC).GE.0).AND. 1(TF(IC).LE.0))) THEN !WB IF THE SED IN TRANSPORT IS GT TRANS CAP, YOU WILL HAVE !WB A NEGATIVE DCAP, SO SET DACT=0 !RZ DACT=ACTual Detachment DACT(M,IC)=0 ELSE DACT(M,IC)=DCAP*(1-(SST(M,IC)/TF(IC))) !RZ see equation 17 in Wes Byne's thesis. END IF IF (DACT(M,IC).GT.DCAP) THEN !WB THIS WOULD OCCUR IF THERE WAS A PROGRAM ERROR, FOR INSTANCE IF AN !WB ARRAY OVERFLOWED. WRITE (2,1008) DACT(M,IC),M,IC,DCAP WRITE (*,1008) DACT(M,IC),M,IC,DCAP STOP ENDIF END DO IF (DACT(M,IC).GT.10) THEN !WB JUST A GENERAL ERROR CHECK, DACT IS IN KG/S WRITE (*,*) 'DACT(M,IC) GT 10',DACT(M,IC),M,IC PAUSE ENDIF IF (M.GT.N) GO TO 9405 !WB IF ITS A CHANNEL CELL, THEN JUMP DOWN TO CHANNEL DETACHMENT !WB **************** Rainfall detachment ********************** RNOFIR=QEFF/(DX*RILLSPC(JK)) IF (RNOFIR.GT.1) THEN !WB GENERAL ERROR CHECK WRITE (2,*) 'RNOFIR EXCEEDS 1',M ! PAUSE !RZ PAUSE COMMENTED OUT AND MSG WRITTEN TO OUTPUT FILE SO THE THING WILL RUN 11/11/01 ENDIF !WB rnofir=interrill runoff rate, assumed equal to the effective runoff !WB rate per rill / (flow length*distance b/t rills). This equals the !WB flowdepth at present time !RZ RuNOFf InterRill !WB ******** sediment delivery ratio calculation ******* !WB This information comes from table 8.4 and 8.5 by Foster, ASAE !WB monograph # 5. The roughness factor range for the last two !WB categories were changed to give a quantifiable category for !WB a smooth surface (see table 8.4). DO IC=1,NPART IF (RANROU(JK).GE.150) THEN !WB rghfact(M)=0.3, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=0.91 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).lt.0.050) SEDDR(M,IC)=0.79 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).lt.0.250) SEDDR(M,IC)=0.37 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).lt.1.000) SEDDR(M,IC)=0.00 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.00 ENDIF IF (RANROU(JK).GE.100.AND.RANROU(JK).LT.150) THEN !WB rghfact(M)=0.5, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=0.97 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=0.93 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=0.75 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=0.00 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.00 ENDIF IF (RANROU(JK).GE.70.AND.RANROU(JK).LT.100) THEN !WB rghfact(M)=0.65, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=0.99 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=0.98 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=0.07 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.17 ENDIF IF (RANROU(JK).GE.50.AND.RANROU(JK).LT.70) THEN !WB rghfact(M)=0.75, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=0.99 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=0.32 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.46 ENDIF IF (RANROU(JK).GE.20.AND.RANROU(JK).LT.50) THEN !WB rghfact(M)=0.85, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=0.99 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=0.58 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.69 ENDIF IF (RANROU(JK).GE.5.AND.RANROU(JK).LT.20) THEN !WB rghfact(M)=0.92, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=0.78 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=0.84 ENDIF IF (RANROU(JK).GE.0.AND.RANROU(JK).LT.5) THEN !WB rghfact(M)=1.00, read table 8.5 for this roughness factor IF (DIAMM(IC).LT.0.002) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.002.AND.DIAMM(IC).LT.0.050) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.050.AND.DIAMM(IC).LT.0.250) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.0.250.AND.DIAMM(IC).LT.1.000) SEDDR(M,IC)=1.00 IF (DIAMM(IC).GE.1.000) SEDDR(M,IC)=1.00 ENDIF END DO DO 9500 IC=1,NPART DIINT(M,IC)=(KIADJ(M)*XR*RNOFIR*SEDDR(M,IC)/AREA) !WB DIINT=INTERRILL DETACHMENT, KIADJ=ADJUSTED INTERRILL ERODIBILITY, !WB XR=NET RAINFALL RATE CONVERTED TO M3/S, !WB RNOFIR=INTERRILL RUNOFF RATE,SEDDR=SED DELIVERY !WB RATIO, AREA=AREA OF CELL OR CHANNEL, USED TO ADJUST THE RAINFALL !WB RATE TO A UNIT AREA BASIS, AND THEN THE DETACHMENT IS MULTIPLIED !WB BY AREA BELOW. IF (DIINT(M,IC).GT.100) THEN !WB GENERAL ERROR CHECK WRITE (*,*) 'DIINT EXCEEDS 100' WRITE (2,*) 'DIINT EXCEEDS 100' PAUSE STOP ENDIF DIINT(M,IC)=DIINT(M,IC)*((DX*DX)-(NORILLS*RILLWID*DX)) !WB THIS SAYS THAT THE INTERRILL CONTRIBUTION IN KG/S*M2 SHOULD BE !WB MULTIPLIED BY THE INTERRILL AREA, WHICH EQUALS THE CELL AREA !WB MINUS THE RILL AREA 9500 END DO DO IC=1,NPART DETR(IC)=DIINT(M,IC) !WB rainfall detachment (kg/s) = DETF(IC)=DACT(M,IC) !WB flow detachment (kg/s) = IF (NOEROS(JK).EQ.1) THEN !WB THIS IS A FLAG THAT INDICATES A COVER CONDITION THAT DOES NOT INCUR !WB EROSION, SUCH AS A PARKING LOT OR POND DETR(IC)=0. DETF(IC)=0. ENDIF END DO GO TO 75 9405 CONTINUE 70 DO IC=1,NPART DETR(IC)=0. !WB reset rainfall detach to 0 DETF(IC)=DACT(M,IC) !WB you are sent here to reset flow and rainfall detachment if the !WB element is a channel cell !WB IF AN ELEMENT HAS A NOEROS FLAG, IT DOES NOT AFFECT EROSION IN A !WB CHANNEL CELL OF THAT ELEMENT. END DO 75 CONTINUE !WB you skip the reset of the rainfall and flow detachments to 0 if !WB you are still doing calculations on overland flow cells DO IC=1,NPART DRFT(IC)=DETR(IC)+DETF(IC) !WB sum of rainfall & flow detach (kg/s) END DO X1=Q(M)/S(M) !WB X1 = flow / water storage on element !WB (it's a volumetric flow/volum storage) X2=1./(1.+X1) !WB X2 = 1 / (1+flow/storage) !WB this is also: storage/(storage+flow) IF(NP.EQ.NWASH1.AND.NWASH.NE.0) GO TO 310 !WB if np equals NWASH + 1 and # of washload particles doesn't equal 0 !WB line 310 is the beginning of the washload particle calculations X3=X1*X2 !WB X3 = (flow / storage) * (1 / (1+flow/storage)) !WB this is also flow/(flow+storage X4=1./X1 !WB X4 = storage / flow DO 80 IC=NWASH1,NPART !WB do from counter IC = # washload particles + 1 up to # of particles DS1(IC)=SI(M,IC)+F(KK,IC)*DETR(IC) !WB max rate of sed. inflow & erosion in element with only rainfall !WB detach (kg/s) = sed. inflow + fraction of particles of type i in !WB original soil * detach rate for rainfall DS2(IC)=DS1(IC)+F(KK,IC)*DETF(IC) !WB max rate of sed inflow & erosion in element with rainfall & !WB flow detachment (kg/s) = above + fraction of particles of type i in !WB original soil (soil type of current element, particle size class) !WB * flow detachment (kg/s) S22(IC)=(SST(M,IC)+DS2(IC))*X2 !WB S22 = (sum of initial values in sed. cont eqn (kg/s) + !WB max rate sed inflow & erosion w/ rainfall & flow detach (kg/s)) * !WB (1/(1+(flow/storage))) SE1(IC)=(SST(M,IC)+DS1(IC))*X3 !WB SE1 (rate of sed movement w/o flow detachment !WB = (sum of initial values in sed cont eqn + !WB max rate of sed. movement w/ rainfall detach) * X3 SE2(IC)=S22(IC)*X1 !WB SE2 (rate of sed movement w/ rainfall and flow detachment !WB = sed cont eqn + erosion w/rainfall & flow detach * (1/1+ !WB (flow/storage)) * flow/storage 80 CONTINUE !WB you are sent here after completing the last loop for the # of !WB settleable size classes C C.........APPORTION ANY TRANSPORT EXCESS TO DEFICITS.......... C NPM=NPART-NWASH !WB NPM = # of particle size classes - # of washload size classes !WB this is equal to the # of settleable size classes 90 I1=0 !WB counter !WB you are sent here from later in the prog I2=0 !WB counter I3=0 !WB counter SDEL=0. !WB sum of delta TFXCES=0. !WB trans cap excess !WB********calculate transport capacity excess ****************** DO 150 IC=NWASH1,NPART !WB do from nwashload part's + 1 to # particle size classes TFMSE2(IC)=TF(IC)-SE2(IC) !WB = trans cap - sediment w/ rainfall and flow detach IF(TFMSE2(IC))130,140,110 !WB if above var < = > 0, then go to 130, 140, 110, respectively !WB this says, is trans cap less than sediment erosion !WB capacity with rainfall and flow detachment, or equal to or !WB greater than C C............TRANSPORT > SE2........................ C !WB this says that the transport capacity exceeds the detachment !WB rate with rainfall and flow detachment 110 I1=I1+1 !WB count TFXCES=TFXCES+TFMSE2(IC) !WB trans cap excess = excess + (cap - no flow detachment) !WB this says that the excess is equal to the previous excess + the !WB definition of trans cap excess TF(IC)=SE2(IC) !WB trans cap = rate of sed movement w/ rainfall and flow detach !WB set trans cap equal to the detachment rate if you have an excess !WB of t.c. GO TO 150 C C............TRANSPORT < SE2........................ C !WB this says that if the transport capacity is less than the !WB detachment rate 130 I3=I3+1 !WB count SDEL=SDEL+DELTA(IC) !WB summ of delta = same + delta (= dimensionless crit shear) 140 I2=I2+1 !WB count. You are sent here if the t.c. excess is equal to the !WB detachment rate. 150 CONTINUE !WB you are sent here to skip the I3 counter and the sum of delta !WB for the condition of t.c. < detachment rate (or equal to det. !WB rate), and the I2 counter IF(SDEL.LE.0.) GO TO 200 !WB sum of delta less than or equal to 0. You get here if t.c. !WB exceeds SE2 for all particle size classes, or if t.c. is !WB equal to SE2 for all particle size classes IF(I1.EQ.NPM.OR.I2.EQ.NPM.OR.I3.EQ.NPM) GO TO 200 !WB if the count equals the # of settleable particle size classes or !WB if count I2 or if count I3 equals the same, then go to 200 !WB this says that if you have gone through the loop the same # !WB of times as the # of settleable particle size classes, then skip !WB the reapportionment of trans capacity !WB********end of transport capacity excess loop/section******** !WB ***********reapportion the transport capacity************ !WB I believe that this loop is done until T.C < SE2 DO 160 IC=NWASH1,NPART !WB do from the counter that represents the # of particle size classes !WB that are settleable up to the # of particles IF(TFMSE2(IC).GE.0..OR.DELTA(IC).LE.0.) GO TO 160 !WB if trans cap excess > 0 or delta (= excess tractive force) < 0 TF(IC)=TF(IC)+TFXCES*DELTA(IC)/SDEL !WB trans cap = same + accum trans cap excess * delta / sum of deltas IF(I3.EQ.1) GO TO 170 !WB if the I3 counter equals 1, which occurs when t.c. is lt se2, !WB and there won't be sufficient energy for transport, and then 160 CONTINUE GO TO 90 !WB this sends you back to the top to redo the calculations on trans !WB capacity. you are sent here if trans cap excess is greater than !WB or equal to 0 or if the excess tractive force = 0 170 IF(TF(IC).GT.SE2(IC)) TF(IC)=SE2(IC) !WB if the trans cap > detach rate, then trans cap = !WB detachment rate !WB you get here if the I3 counter is = 1, which means that t.c. < det !WB rate C C.........SOLVE CONTINUITY EQUATION FOR SEDIMENT TRANSPORT..... C 200 CONTINUE !WB you are sent here if any of the counters equals to the # of !WB settleable particle classes DO 300 IC=NWASH1,NPART !WB do from # washload particles + 1 up to # particles size classes !WB I believe that the NWASH1 var is used to keep count of the same !WB thing as NPM IF(TF(IC).LT.SE1(IC)) GO TO 240 !WB if trans cap < rainfall detach IF(TF(IC).LT.SE2(IC)) GO TO 220 !WB if trans cap < max detach rate with rainfall & flow !WB so you jump over the next section if the trans cap is not equal !WB to maximum, and you're directed according to the amt of detachment C C..........MAXIMUM RAINFALL AND FLOW DETACHMENT............... C...................NO DEPOSITION............................. C !WB this is the section for t.c.>SE2 and so all detachment can be !WB transported SST(M,IC)=DS2(IC)-SE2(IC)+S22(IC) !WB SST = (detachment rate w/rainfall & flow detach + sed inflow prev !WB time step) - !WB [(sed cont eqn prev time step + !WB detachment w/ rainfall & flow detach)*(1/1+ !WB (flow/storage)) * flow/storage] * !WB (flow/storage) + [sed cont eqn prev time step + !WB detachment w/ rainfall & flow detach)*(1/(1+(flow/storage)))] C *** NRZ C *** CHANNEL ADDITION SE(IC)=SE2(IC) !WB sediment movement from a cell is equal to max detach rate !WB with rainfall & flow C *** NRZ END SEL(M)=SEL(M)-F(KK,IC)*DRFT(IC) !WB sed accum = sed accum (per storm) - fraction of particles in !WB class i * sum of rainfall & detachment *DETERMING THE NEWLY GENERATED SEDIMENT SEDNEW(M,IC)=F(KK,IC)*DRFT(IC) !WB sednew = fraction of particles in class i * sum of rainfall & !WB detach STNEW(IC)=S22(IC)/2. !WB new soil storage !WB this says that the new soil storage is equal to: !WB [sed cont eqn + erosion w/rainfall & flow detach * (1/1+ !WB (flow/storage))] / 2 GO TO 290 !WB this sends you down to the section on washload particle calculation !WB and then out the bottom of this subroutine C C..........MAXIMUM RAINFALL, PARTIAL FLOW DETACHMENT.......... C.....................NO DEPOSITION........................... C !WB This is the section for when t.c. 0, then go to 130, 140, 110, respectively !WB this says, is trans cap less than sediment erosion !WB capacity with rainfall and flow detachment, or equal to or !WB greater than C C............TRANSPORT > SE2........................ C !WB this says that the transport capacity exceeds the detachment !WB rate with rainfall and flow detachment 1110 I1=I1+1 !WB count TFXCES=TFXCES+TFMSE2(IC) !WB trans cap excess = excess + (cap - no flow detachment) !WB this says that the excess is equal to the previous excess + the !WB definition of trans cap excess TF(IC)=SE2(IC) !WB trans cap = rate of sed movement w/ rainfall and flow detach !WB set trans cap equal to the detachment rate if you have an excess !WB of t.c. GO TO 1150 C C............TRANSPORT < SE2........................ C !WB this says that if the transport capacity is less than the !WB detachment rate 1130 I3=I3+1 !WB count SDEL=SDEL+DELTA(IC) !WB summ of delta = same + delta (= dimensionless crit shear) 1140 I2=I2+1 !WB count. You are sent here if the t.c. excess is equal to the !WB detachment rate. 1150 CONTINUE !WB you are sent here to skip the I3 counter and the sum of delta !WB for the condition of t.c. < detachment rate (or equal to det. !WB rate), and the I2 counter IF(SDEL.LE.0.) GO TO 1200 !WB sum of delta less than or equal to 0. You get here if t.c. !WB exceeds SE2 for all particle size classes, or if t.c. is !WB equal to SE2 for all particle size classes IF(I1.EQ.NPM.OR.I2.EQ.NPM.OR.I3.EQ.NPM) GO TO 1200 !WB if the count equals the # of settleable particle size classes or !WB if count I2 or if count I3 equals the same, then go to 200 !WB this says that if you have gone through the loop the same # !WB of times as the # of settleable particle size classes, then skip !WB the reapportionment of trans capacity !WB********end of transport capacity excess loop/section******** !WB ***********reapportion the transport capacity************ !WB I believe that this loop is done until T.C < SE2 DO 1160 IC=NWASH1,NPART !WB do from the counter that represents the # of particle size classes !WB that are settleable up to the # of particles IF(TFMSE2(IC).GE.0..OR.DELTA(IC).LE.0.) GO TO 1160 !WB if trans cap excess > 0 or delta (= excess tractive force) < 0 TF(IC)=TF(IC)+TFXCES*DELTA(IC)/SDEL !WB trans cap = same + accum trans cap excess * delta / sum of deltas IF(I3.EQ.1) GO TO 1170 !WB if the I3 counter equals 1, which occurs when t.c. is lt se2, !WB and there won't be sufficient energy for transport, and then 1160 CONTINUE GO TO 190 !WB this sends you back to the top to redo the calculations on trans !WB capacity. you are sent here if trans cap excess is greater than !WB or equal to 0 or if the excess tractive force = 0 1170 IF(TF(IC).GT.SE2(IC)) TF(IC)=SE2(IC) !WB if the trans cap > detach rate, then trans cap = !WB detachment rate !WB you get here if the I3 counter is = 1, which means that t.c. < det !WB rate C C.........SOLVE CONTINUITY EQUATION FOR SEDIMENT TRANSPORT..... C 1200 CONTINUE !WB you are sent here if any of the counters equals to the # of !WB settleable particle classes DO 1300 IC=NWASH1,NPART !WB do from # washload particles + 1 up to # particles size classes !WB I believe that the NWASH1 var is used to keep count of the same !WB thing as NPM IF(TF(IC).LT.SE1(IC)) GO TO 1240 !WB if trans cap < rainfall detach IF(TF(IC).LT.SE2(IC)) GO TO 1220 !WB if trans cap < max detach rate with rainfall & flow !WB so you jump over the next section if the trans cap is not equal !WB to maximum, and you're directed according to the amt of detachment C C..........MAXIMUM RAINFALL AND FLOW DETACHMENT............... C...................NO DEPOSITION............................. C !WB this is the section for t.c.>SE2 and so all detachment can be !WB transported SST(M,IC)=DS2(IC)-SE2(IC)+S22(IC) !WB SST = (detachment rate w/rainfall & flow detach + sed inflow prev !WB time step) - !WB [(sed cont eqn prev time step + !WB detachment w/ rainfall & flow detach)*(1/1+ !WB (flow/storage)) * flow/storage] * !WB (flow/storage) + [sed cont eqn prev time step + !WB detachment w/ rainfall & flow detach)*(1/(1+(flow/storage)))] !RZ sediment in transport = detached soil - sediment exiting + sediment already !RZ in transport? C *** NRZ C *** CHANNEL ADDITION SE(IC)=SE2(IC) !WB sediment movement from a cell is equal to max detach rate !WB with rainfall & flow C *** NRZ END SEL(M)=SEL(M)-DRFT(IC) ! F(KK,IC) was taken out as DRFT is already in terms of the particle ! size class. !WB sed accum = sed accum (per storm) - fraction of particles in !WB class i * sum of rainfall & detachment IF (SEL(M).LT.0) SEL(M) = 0. ! Below: accumulated sediment in each particle size class is calculated SEL2(M,IC)=SEL2(M,IC)-DRFT(IC) IF(SEL2(M,IC).LT.0.) SEL2(M,IC)=0. ! Above, a check to make sure SEL2 does not fall below zero (not possible ! as impervious area is not erodible). *DETERMING THE NEWLY GENERATED SEDIMENT SEDNEW(M,IC)=DRFT(IC) ! Again, F(kk,ic) is taken out b/c DRFT is already in terms of particle size class. !WB sednew = fraction of particles in class i * sum of rainfall & !WB detach STNEW(IC)=S22(IC)/2. !WB new soil storage !WB this says that the new soil storage is equal to: !WB [sed cont eqn + erosion w/rainfall & flow detach * (1/1+ !WB (flow/storage))] / 2 GO TO 1290 !WB this sends you down to the section on washload particle calculation !WB and then out the bottom of this subroutine C C..........MAXIMUM RAINFALL, PARTIAL FLOW DETACHMENT.......... C.....................NO DEPOSITION........................... C !WB This is the section for when t.c.