diff --git a/VERSIONS b/VERSIONS index c92c2f1..fbfb2e1 100644 --- a/VERSIONS +++ b/VERSIONS @@ -1,3 +1,3 @@ VERSION_MAJOR 2012 -VERSION_MINOR 535 +VERSION_MINOR 582 VERSION_PATCH \ No newline at end of file diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 585dd49..021b825 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -3,10 +3,11 @@ set(swatexe swat) ### Get source file lists of different formats file(GLOB F77SRCS *.f) +file(GLOB F90SRCS *.f90) ### Set Fortran line format for source file ## Special sources that have fixed length of 79 -set(LEN79_SRCS "bmp_det_pond" "bmpinit" "ovr_sed" "percmain" "readbsn" "rthsed") +set(LEN79_SRCS "bmp_det_pond" "bmpinit" "ovr_sed" "percmain" "readbsn" "rthsed" "modparm" "main") foreach(F77FILE ${F77SRCS}) get_filename_component(CORENAME ${F77FILE} NAME_WE) list(FIND LEN79_SRCS ${CORENAME} _FOUND_LEN79) @@ -34,6 +35,18 @@ foreach(F77FILE ${F77SRCS}) endif() endforeach() +foreach(F90FILE ${F90SRCS}) + if(${CMAKE_Fortran_COMPILER} MATCHES "ifort.*") + if(MSVC) + set_source_files_properties(${F90FILE} PROPERTIES COMPILE_FLAGS /4L132) + else() + set_source_files_properties(${F90FILE} PROPERTIES COMPILE_FLAGS -132) + endif() + else() # gfortran tested only + set_source_files_properties(${F90FILE} PROPERTIES COMPILE_FLAGS -ffree-line-length-none) + endif() +endforeach() + ### Customize compile process according to versions of 'main.f' for gfortran file(READ ${CMAKE_SOURCE_DIR}/src/main.f First_Line_Of_Main_File OFFSET 0 LIMIT 26) ## Situation 1: The first line of main.f is "include 'modparm.f'" @@ -45,10 +58,10 @@ if((NOT MSVC) AND (${First_Line_Of_Main_File} MATCHES " include 'modparm.f' endif () # Build main.f first which includes modparm.f (i.e., parm.mod) add_custom_command(OUTPUT main.o - COMMAND ${CMAKE_Fortran_COMPILER} ${Compile_Flags_List} -ffixed-line-length-72 -c + COMMAND ${CMAKE_Fortran_COMPILER} ${Compile_Flags_List} -ffixed-line-length-79 -c ${CMAKE_CURRENT_SOURCE_DIR}/modparm.f ${CMAKE_CURRENT_SOURCE_DIR}/main.f) # Build other source files that depend on main.o - foreach(SRCFILE ${F77SRCS}) + foreach(SRCFILE ${F77SRCS} ${F90SRCS}) get_filename_component(CORENAME ${SRCFILE} NAME_WE) get_filename_component(ext ${SRCFILE} EXT) # Excludes main.f and modparm.f @@ -56,7 +69,11 @@ if((NOT MSVC) AND (${First_Line_Of_Main_File} MATCHES " include 'modparm.f' continue() endif() # Set compile flag according to Fortran line format. These should be consistent with settings above. - set(Format_Flag "-ffixed-line-length-72") + if(${ext} STREQUAL ".f") + set(Format_Flag "-ffixed-line-length-72") + else() + set(Format_Flag "-ffree-line-length-none") + endif() list(FIND LEN79_SRCS ${CORENAME} _FOUND_LEN79) if(${_FOUND_LEN79} GREATER -1) set(Format_Flag "-ffixed-line-length-79") @@ -71,7 +88,7 @@ if((NOT MSVC) AND (${First_Line_Of_Main_File} MATCHES " include 'modparm.f' add_executable(${swatexe} ${swat_obj} main.o) ## Situation 2: The first line of main.f is not "include 'modparm.f'", the command is same for ifort(MSVC) and gfortran else() - add_executable(${swatexe} ${F77SRCS}) + add_executable(${swatexe} ${F77SRCS} ${F90SRCS}) endif() ### Set exact name of SWAT executable according to versions and build type diff --git a/src/NCsed_leach.f90 b/src/NCsed_leach.f90 new file mode 100644 index 0000000..72928dd --- /dev/null +++ b/src/NCsed_leach.f90 @@ -0,0 +1,225 @@ + subroutine orgncswat2(iwave) + +!! ~ ~ ~ PURPOSE ~ ~ ~ +!! this subroutine calculates the amount of organic nitrogen removed in +!! surface runoff - when using CSWAT==2 it + + +!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! da_ha |ha |area of watershed in hectares +!! enratio |none |enrichment ratio calculated for day in HRU +!! erorgn(:) |none |organic N enrichment ratio, if left blank +!! |the model will calculate for every event +!! ihru |none |HRU number +!! iwave |none |flag to differentiate calculation of HRU and +!! |subbasin sediment calculation +!! |iwave = 0 for HRU +!! |iwave = subbasin # for subbasin +!! sedyld(:) |metric tons |daily soil loss caused by water erosion in +!! |HRU +!! sol_bd(:,:) |Mg/m**3 |bulk density of the soil +!! sol_z(:,:) |mm |depth to bottom of soil layer +!! sub_bd(:) |Mg/m^3 |bulk density in subbasin first soil layer +!! sub_fr(:) |none |fraction of watershed area in subbasin +!! sub_orgn(:) |kg N/ha |amount of nitrogen stored in all organic +!! sedc_d(:) |kg C/ha |amount of C lost with sediment +!! +!! +!! +!! |pools +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! sedorgn(:) |kg N/ha |amount of organic nitrogen in surface runoff +!! |in HRU for the day +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! conc | |concentration of organic N in soil +!! er |none |enrichment ratio +!! j |none |HRU number +!! wt1 |none |conversion factor (mg/kg => kg/ha) +!! xx |kg N/ha |amount of organic N in first soil layer +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ + + use parm + + integer, intent (in) :: iwave + integer :: j + real :: xx, wt1, er, conc + real :: sol_mass, QBC, VBC, YBC, YOC, YW, TOT, YEW, X1, PRMT_21, PRMT_44 + real :: DK, V, X3, CO, CS, perc_clyr, latc_clyr + integer :: k + latc_clyr = 0. + + j = 0 + j = ihru + + !!for debug purpose by zhang + !if (iyr == 1991 .and. i==235) then + ! write(*,*) 'stop' + !end if + + xx = 0. + wt1 = 0. !! conversion factor + er = 0. !! enrichment ratio + if (iwave <= 0) then + !! HRU calculations + !xx = sol_n(1,j) + sol_fon(1,j) + sol_mn(1,j) + xx = sol_LSN(1,j)+sol_LMN(1,j)+sol_HPN(1,j)+sol_HSN(1,j) !+sol_BMN(1,j) + !wt = sol_bd(1,j) * sol_z(1,j) * 10. (tons/ha) + !wt1 = wt/1000 + wt1 = sol_bd(1,j) * sol_z(1,j) / 100. + + if (erorgn(j) > .001) then + er = erorgn(j) + else + er = enratio + end if + + else + !! subbasin calculations + xx = sub_orgn(iwave) + wt1 = sub_bd(iwave) * sol_z(1,j) / 100. + + er = enratio + end if + + conc = 0. + conc = xx * er / wt1 + + if (iwave <= 0) then + !! HRU calculations + sedorgn(j) = .001 * conc * sedyld(j) / hru_ha(j) + else + !! subbasin calculations + sedorgn(j) = .001 * conc * sedyld(j) / (da_ha * sub_fr(iwave)) + end if + + !! update soil nitrogen pools only for HRU calculations + if (iwave <= 0 .and. xx > 1.e-6) then + xx1 = (1. - sedorgn(j) / xx) + + !!add by zhang to update soil nitrogen pools + + sol_LSN(1,j) = sol_LSN(1,j) * xx1 + sol_LMN(1,j) = sol_LMN(1,j) * xx1 + sol_HPN(1,j) = sol_HPN(1,j) * xx1 + sol_HSN(1,j) = sol_HSN(1,j) * xx1 + !sol_BMN(1,j) = sol_BMN(1,j) * xx1 + end if + + !return + + !Calculate runoff and leached C&N from micro-biomass + latc_clyr = 0. + sol_mass = 0. + !kg/ha + sol_mass = (sol_z(1,j) / 1000.) * 10000. * sol_bd(1,j)* 1000. * (1- sol_rock(1,j) / 100.) + + + QBC=0. !c loss with runoff or lateral flow + VBC=0. !c los with vertical flow + YBC=0. !BMC LOSS WITH SEDIMENT + YOC=0. !Organic C loss with sediment + YW=0. !YW = WIND EROSION (T/HA) + TOT=sol_HPC(1,j)+sol_HSC(1,j)+sol_LMC(1,j)+sol_LSC(1,j) !Total organic carbon in layer 1 + !YEW = MIN(er*(sedyld(j)/hru_ha(j)+YW/hru_ha(j))/(sol_mass/1000.),.9) + ! Not sure whether should consider enrichment ratio or not! + YEW = MIN((sedyld(j)/hru_ha(j)+YW/hru_ha(j))/(sol_mass/1000.),.9) !fraction of soil erosion of total soil mass + X1=1.-YEW + !YEW=MIN(ER*(YSD(NDRV)+YW)/WT(LD1),.9) + !ER enrichment ratio + !YSD water erosion + !YW wind erosion + YOC=YEW*TOT + sol_HSC(1,j)=sol_HSC(1,j)*X1 + sol_HPC(1,j)=sol_HPC(1,j)*X1 + sol_LS(1,j)=sol_LS(1,j)*X1 + sol_LM(1,j)=sol_LM(1,j)*X1 + sol_LSL(1,j)=sol_LSL(1,j)*X1 + sol_LSC(1,j)=sol_LSC(1,j)*X1 + sol_LMC(1,j)=sol_LMC(1,j)*X1 + sol_LSLC(1,j)=sol_LSLC(1,j)*X1 + sol_LSLNC(1,j)=sol_LSC(1,j)-sol_LSLC(1,j) + if (surfq(j) > 0) then + !write(*,*) 'stop' + end if + IF(sol_BMC(1,j)>.01) THEN + PRMT_21 = 0. !KOC FOR CARBON LOSS IN WATER AND SEDIMENT(500._1500.) KD = KOC * C + PRMT_21 = 1000. + sol_WOC(1,j) = sol_LSC(1,j)+sol_LMC(1,j)+sol_HPC(1,j)+sol_HSC(1,j)+sol_BMC(1,j) + DK=.0001*PRMT_21*sol_WOC(1,j) + !X1=PO(LD1)-S15(LD1) + X1 = sol_por(1,j)*sol_z(1,j)-sol_wpmm(1,j) !mm + IF (X1 <= 0.) THEN + X1 = 0.01 + END IF + XX=X1+DK + !V=QD+Y4 + V = surfq(j) + sol_prk(1,j) + flat(1,j) + !QD surface runoff + X3=0. + IF(V>1.E-10)THEN + X3=sol_BMC(1,j)*(1.-EXP(-V/XX)) !loss of biomass C + PRMT_44 = 0. !RATIO OF SOLUBLE C CONCENTRATION IN RUNOFF TO PERCOLATE(0.1_1.) + PRMT_44 = .5 + CO=X3/(sol_prk(1,j) + PRMT_44*(surfq(j)+flat(1,j))) !CS is the horizontal concentration + CS=PRMT_44*CO !CO is the vertical concentration + VBC=CO*(sol_prk(1,j)) !!! sol_prk(:,:) |mm H2O |percolation from soil layer on current day + sol_BMC(1,j)=sol_BMC(1,j)-X3 + QBC=CS*(surfq(j)+flat(1,j)) + ! COMPUTE WBMC LOSS WITH SEDIMENT + IF(YEW>0.)THEN + CS=DK*sol_BMC(1,j)/XX + YBC=YEW*CS + END IF + END IF + END IF + + sol_BMC(1,j)=sol_BMC(1,j)-YBC + surfqc_d(j) = QBC*(surfq(j)/(surfq(j)+flat(1,j)+1.e-6)) + + sol_latc(1,j) = QBC*(flat(1,j)/(surfq(j)+flat(1,j)+1.e-6)) + sol_percc(1,j) = VBC + sedc_d(j) = YOC + YBC + + latc_clyr = latc_clyr + sol_latc(1,j) + DO k=2,sol_nly(j) + if (sol_prk(k,j) > 0 .and. k == sol_nly(j)) then + !write (*,*) 'stop' + end if + sol_thick = 0. + sol_thick = sol_z(k,j)-sol_z(k-1,j) + sol_WOC(k,j) = sol_LSC(k,j)+sol_LMC(k,j)+sol_HPC(k,j)+sol_HSC(k,j) + Y1=sol_BMC(k,j)+VBC + VBC=0. + IF(Y1>=.01)THEN + V=sol_prk(k,j) + flat(k,j) + IF(V>0.)VBC=Y1*(1.-EXP(-V/(sol_por(k,j)*sol_thick-sol_wpmm(k,j)+.0001*PRMT_21*sol_WOC(k,j)))) + END IF + sol_latc(k,j) = VBC*(flat(k,j)/(sol_prk(k,j) + flat(k,j)+1.e-6)) + sol_percc(k,j) = VBC-sol_latc(k,j) + sol_BMC(k,j)=Y1-VBC + + !! calculate nitrate in percolate + !perc_clyr = 0. + perc_clyr = perc_clyr + sol_percc(k,j) + + latc_clyr = latc_clyr + sol_latc(k,j) + END DO + + latc_d(j) = latc_clyr + percc_d(j) = perc_clyr + + + return + end diff --git a/src/allocate_parms.f b/src/allocate_parms.f index a24a153..8e0f98d 100644 --- a/src/allocate_parms.f +++ b/src/allocate_parms.f @@ -51,13 +51,12 @@ subroutine allocate_parms !! initialize variables mvaro = 33 - mhruo = 76 + mhruo = 78 mrcho = 62 ! msubo = 18 ! changed for jennifer b msubo = 22 - mstdo = 112 - iopera = 200 + mstdo = 113 motot = 600 !! (50 years limit) !!!!!!!!!! drains @@ -86,20 +85,22 @@ subroutine allocate_parms mxsubch = Max(msub+1,mch+1) itempa = Max(mhru,mch) - !! new arrays for routing units - mhru_sub = 100 !! needs to be allocated -!! added mru below because of error after adding 7/30/2010 changes from NBS gsm 8/3/2010 - mru = rutot - allocate (hru_rufr(mru,mhru_sub)) - allocate (daru_km(mru)) + allocate (hru_rufr(mru,mhru)) + allocate (daru_km(msub,mru)) + allocate (ru_k(msub,mru)) + allocate (ru_c(msub,mru)) + allocate (ru_eiq(msub,mru)) + allocate (ru_ovs(msub,mru)) + allocate (ru_ovsl(msub,mru)) + allocate (ru_a(msub,mru)) + allocate (ru_ktc(msub,mru)) allocate (gwq_ru(mhru)) allocate (mhyd1(msub)) + allocate (ils2(mhru)) + allocate (ils2flag(msub)) allocate (irtun(msub)) -!! array that contains seeds for the random generator -!! allocate (iseed(1)) -!! arrays which contain data related to the number of rechour commands allocate (ifirsthr(mrech)) !! arrays which contain data related to the number of recday commands @@ -392,9 +393,11 @@ subroutine allocate_parms allocate (sub_gwno3(msub)) allocate (sub_gwsolp(msub)) allocate (sub_gwq(msub)) + allocate (sub_gwq_d(msub)) allocate (sub_km(msub)) allocate (sub_lat(msub)) allocate (sub_latq(msub)) + allocate (sub_tileq(msub)) allocate (sub_latno3(msub)) allocate (sub_minp(msub)) allocate (sub_minpa(msub)) @@ -832,6 +835,9 @@ subroutine allocate_parms allocate (inum3s(mhyd)) allocate (inum4s(mhyd)) allocate (inum5s(mhyd)) + allocate (inum6s(mhyd)) + allocate (inum7s(mhyd)) + allocate (inum8s(mhyd)) allocate (reccnstps(mhyd)) allocate (recmonps(mhyd)) allocate (rnum1s(mhyd)) @@ -850,7 +856,9 @@ subroutine allocate_parms allocate (afrt_surface(mhru)) allocate (aird(mhru)) allocate (alpha_bf(mhru)) + allocate (alpha_bf_d(mhru)) allocate (alpha_bfe(mhru)) + allocate (alpha_bfe_d(mhru)) allocate (anano3(mhru)) allocate (anion_excl(mhru)) allocate (auto_eff(mhru)) @@ -956,6 +964,7 @@ subroutine allocate_parms allocate (gw_delaye(mhru)) allocate (gw_nloss(mhru)) allocate (gw_q(mhru)) + allocate (gw_qdeep(mhru)) allocate (gw_revap(mhru)) allocate (gw_spyld(mhru)) allocate (gwht(mhru)) @@ -994,6 +1003,7 @@ subroutine allocate_parms allocate (iopyr(iopera,mhru)) allocate (mgt_ops(iopera,mhru)) allocate (ioper(mhru)) +! allocate (mcri(mhru)) allocate (mgt_sdr(iopera,mhru)) allocate (mgtop(iopera,mhru)) allocate (idop(iopera,mhru)) @@ -1014,7 +1024,6 @@ subroutine allocate_parms allocate (isweep(mhru)) allocate (phusw(mhru)) allocate (phusw_nocrop(mhru)) - allocate (pst_dep(mapp,mhru)) allocate (bio_targ(mhru)) allocate (irr_flag(mhru)) allocate (irra_flag(mhru)) @@ -1067,7 +1076,6 @@ subroutine allocate_parms allocate (nop(mhru)) allocate (no3gw(mhru)) allocate (npcp(mhru)) - allocate (npest(mhru)) allocate (nplnt(mhru)) allocate (nrelease(mhru)) allocate (nro(mhru)) @@ -1145,6 +1153,8 @@ subroutine allocate_parms allocate (pot_fr(mhru)) allocate (pot_no3(mhru)) allocate (pot_no3l(mhru)) + allocate (pot_k(mhru)) + allocate (pot_solpl(mhru)) allocate (pot_nsed(mhru)) allocate (pot_sed(mhru)) allocate (pot_san(mhru)) @@ -1171,6 +1181,7 @@ subroutine allocate_parms allocate (pplnt(mhru)) allocate (qdr(mhru)) + allocate (qdayout(mhru)) allocate (rch_dakm(mxsubch)) allocate (rchrg(mhru)) allocate (rchrg_n(mhru)) @@ -1188,6 +1199,7 @@ subroutine allocate_parms allocate (sci(mhru)) ! Drainmod tile equations 01/2006 allocate (sdrain(mhru)) + allocate (sstmaxd(mhru)) ! Drainmod tile equations 01/2006 allocate (seccip(mhru)) allocate (secciw(mhru)) @@ -1276,6 +1288,8 @@ subroutine allocate_parms allocate (twash(mhru)) allocate (u10(mhru)) allocate (urblu(mhru)) + allocate (usle_cfac(mhru)) + allocate (usle_eifac(mhru)) allocate (usle_k(mhru)) allocate (usle_mult(mhru)) allocate (usle_ls(mhru)) @@ -1313,13 +1327,11 @@ subroutine allocate_parms allocate (wet_sag(mhru)) allocate (wet_lag(mhru)) - allocate (frad(mhru,24)) - allocate (hhsubp(mhru,24)) + allocate (frad(mhru,nstep)) +! allocate (hhsubp(mhru,24)) - !! allocate (rainsub(mhru,nstep)) - allocate (rhrbsb(24)) + ! allocate (rhrbsb(24)) allocate (rstpbsb(nstep)) - !! allocate (precipdt(nstep+1)) allocate (rainsub(mhru,nstep)) allocate (precipdt(nstep+1)) @@ -1369,8 +1381,8 @@ subroutine allocate_parms allocate (icols(mhruo)) allocate (ipdvas(mhruo)) allocate (hrumono(73,mhru)) - allocate (hruyro(70,mhru)) - allocate (hruaao(70,mhru)) + allocate (hruyro(73,mhru)) + allocate (hruaao(73,mhru)) allocate (wtrmon(40,mhru)) allocate (wtryr(40,mhru)) allocate (wtraa(40,mhru)) @@ -1468,7 +1480,7 @@ subroutine allocate_parms ! allocate (hsolp(24)) ! allocate (hsolpst(24)) ! allocate (hsorpst(24)) - allocate (hhprecip(24)) + ! allocate (hhprecip(24)) allocate (halgae(nstep)) allocate (hbactlp(nstep)) allocate (hbactp(nstep)) @@ -1647,15 +1659,109 @@ subroutine allocate_parms & wtp_pmann(mhyd),wtp_ploss(mhyd),wtp_k(mhyd), & wtp_dp(mhyd),wtp_sedi(mhyd),wtp_sede(mhyd),wtp_qi(mhyd)) - + + !! By Zhang for C/N cycling + !! ============================ + !allocate(sol_PH(mlyr,mhru)) + allocate(sol_CAC(mlyr,mhru)) + allocate(sol_CEC(mlyr,mhru)) + allocate(sol_BMC(mlyr,mhru)) + allocate(sol_BMN(mlyr,mhru)) + allocate(sol_HSC(mlyr,mhru)) + allocate(sol_HSN(mlyr,mhru)) + allocate(sol_HPC(mlyr,mhru)) + allocate(sol_HPN(mlyr,mhru)) + allocate(sol_LM(mlyr,mhru)) + allocate(sol_LMC(mlyr,mhru)) + allocate(sol_LMN(mlyr,mhru)) + allocate(sol_LS(mlyr,mhru)) + allocate(sol_LSC(mlyr,mhru)) + allocate(sol_LSN(mlyr,mhru)) + allocate(sol_LSL(mlyr,mhru)) + allocate(sol_RNMN(mlyr,mhru)) + allocate(sol_LSLC(mlyr,mhru)) + allocate(sol_LSLNC(mlyr,mhru)) + allocate(sol_RSPC(mlyr,mhru)) + allocate(sol_WOC(mlyr,mhru)) + allocate(sol_WON(mlyr,mhru)) + allocate(sol_HP(mlyr,mhru)) + allocate(sol_HS(mlyr,mhru)) + allocate(sol_BM(mlyr,mhru)) + + !daily update + allocate(sol_percc(mlyr,mhru)) + allocate(sol_latc(mlyr,mhru)) + + !!for print out at daily, monthly, and annual scale + allocate(sedc_d(mhru)) + allocate(surfqc_d(mhru)) + allocate(latc_d(mhru)) + allocate(percc_d(mhru)) + allocate(foc_d(mhru)) + allocate(NPPC_d(mhru)) + allocate(rsdc_d(mhru)) + allocate(grainc_d(mhru)) + allocate(stoverc_d(mhru)) + allocate(emitc_d(mhru)) + allocate(soc_d(mhru)) + allocate(rspc_d(mhru)) + + allocate(sub_sedc_d(msub)) + allocate(sub_surfqc_d(msub)) + allocate(sub_latc_d(msub)) + allocate(sub_percc_d(msub)) + allocate(sub_foc_d(msub)) + allocate(sub_NPPC_d(msub)) + allocate(sub_rsdc_d(msub)) + allocate(sub_grainc_d(msub)) + allocate(sub_stoverc_d(msub)) + allocate(sub_emitc_d(msub)) + allocate(sub_soc_d(msub)) + allocate(sub_rspc_d(mhru)) + + allocate(sedc_m(mhru)) + allocate(surfqc_m(mhru)) + allocate(latc_m(mhru)) + allocate(percc_m(mhru)) + allocate(foc_m(mhru)) + allocate(NPPC_m(mhru)) + allocate(rsdc_m(mhru)) + allocate(grainc_m(mhru)) + allocate(stoverc_m(mhru)) + allocate(emitc_m(mhru)) + allocate(soc_m(mhru)) + allocate(rspc_m(mhru)) + + allocate(sedc_a(mhru)) + allocate(surfqc_a(mhru)) + allocate(latc_a(mhru)) + allocate(percc_a(mhru)) + allocate(foc_a(mhru)) + allocate(NPPC_a(mhru)) + allocate(rsdc_a(mhru)) + allocate(grainc_a(mhru)) + allocate(stoverc_a(mhru)) + allocate(emitc_a(mhru)) + allocate(soc_a(mhru)) + allocate(rspc_a(mhru)) + + !Tillage factor on SOM decomposition + allocate(tillage_switch(mhru)) + allocate(tillage_depth(mhru)) + allocate(tillage_days(mhru)) + allocate(tillage_factor(mhru)) + tillage_switch = 0 + tillage_depth = 0. + tillage_days = 0 + tillage_factor = 0. + !! By Zhang for C/N cycling + !! ============================ + call zero0 call zero1 call zero2 call zeroini call zero_urbn - - - - + return end diff --git a/src/anfert.f b/src/anfert.f index 222018e..8e5e205 100644 --- a/src/anfert.f +++ b/src/anfert.f @@ -251,12 +251,65 @@ subroutine anfert & * forgp(ifrt) sol_orgp(ly,j) = sol_orgp(ly,j) + (1. - rtoaf) * xx * & & dwfert* forgp(ifrt) - else + end if + if (cswat == 1) then sol_mc(ly,j) = sol_mc(ly,j) + xx * dwfert * forgn(ifrt)*10. sol_mn(ly,j) = sol_mn(ly,j) + xx * dwfert * forgn(ifrt) sol_mp(ly,j) = sol_mp(ly,j) + xx * dwfert * forgp(ifrt) end if + !! add by zhang + !!================= + if (cswat == 2) then + sol_fop(ly,j) = sol_fop(ly,j) + rtoaf * xx * dwfert & + & * forgp(ifrt) + sol_orgp(ly,j) = sol_orgp(ly,j) + (1. - rtoaf) * xx * & + & dwfert* forgp(ifrt) + !!Allocate organic fertilizer to Slow (SWAT_active) N pool; + sol_HSN(ly,j) = sol_HSN(ly,j) + (1. - rtoaf) * xx & + & * dwfert * forgn(ifrt) + sol_aorgn(ly,j) = sol_HSN(ly,j) + + !orgc_f is the fraction of organic carbon in fertilizer + !for most fertilziers this value is set to 0. + orgc_f = 0.0 + + !X1 is fertlizer applied to layer (kg/ha) + !xx is fraction of fertilizer applied to layer + X1 = xx * dwfert + X8 = X1 * orgc_f + RLN = .175 *(orgc_f)/(fminn(ifrt) + forgn(ifrt) + 1.e-5) + X10 = .85-.018*RLN + if (X10<0.01) then + X10 = 0.01 + else + if (X10 > .7) then + X10 = .7 + end if + end if + XXX = X8 * X10 + sol_LMC(ly,j) = sol_LMC(ly,j) + XXX + YY = X1 * X10 + sol_LM(ly,j) = sol_LM(ly,j) + YY + + ZZ = X1 *rtoaf *forgn(ifrt) * X10 + + sol_LMN(ly,j) = sol_LMN(ly,j) + ZZ + sol_LSN(ly,j) = sol_LSN(ly,j) + X1 + & *forgn(ifrt) -ZZ + XZ = X1 *orgc_f-XXX + sol_LSC(ly,j) = sol_LSC(ly,j) + XZ + sol_LSLC(ly,j) = sol_LSLC(ly,j) + XZ * .175 + sol_LSLNC(ly,j) = sol_LSLNC(ly,j) + XZ * (1.-.175) + YZ = X1 - YY + sol_LS(ly,j) = sol_LS(ly,j) + YZ + sol_LSL(ly,j) = sol_LSL(ly,j) + YZ*.175 + + sol_fon(ly,j) = sol_LMN(ly,j) + sol_LSN(ly,j) + + end if + !! add by zhang + !!================= !! check for P stress tfp = 0. diff --git a/src/apex_day.f b/src/apex_day.f index 5e640c6..c394567 100644 --- a/src/apex_day.f +++ b/src/apex_day.f @@ -109,7 +109,7 @@ subroutine apex_day do j = 1, mvaro varoute(j,ihout) = 0. if (ievent > 1) then - do ii = 1, 24 + do ii = 1, nstep hhvaroute(j,ihout,ii) = 0. end do endif diff --git a/src/apply.f b/src/apply.f index 234ef13..41188da 100644 --- a/src/apply.f +++ b/src/apply.f @@ -22,13 +22,11 @@ subroutine apply !! |the watershed !! laiday(:) |none |leaf area index !! nope(:) |none |sequence number of pesticide in NPNO(:) -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! nro(:) |none |sequence number of year in rotation !! nyskip |none |number of years to skip output !! |summarization/printing !! plt_pst(:,:) |kg/ha |pesticide on plant foliage -!! pst_dep(:,:) |kg/ha |depth of pesticide in soil +!! pst_dep |kg/ha |depth of pesticide in soil !! pst_kg |kg/ha |amount of pesticide applied to HRU !! sol_pst(:,:,1)|kg/ha |pesticide in first layer of soil !! wshd_pstap(:)|kg/ha |total amount of pesticide type applied in @@ -40,8 +38,6 @@ subroutine apply !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! drift(:) |kg |amount of pesticide drifting onto main !! |channel in subbasin -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! plt_pst(:,:)|kg/ha |pesticide on plant foliage !! sol_pst(:,:,1)|kg/ha |pesticide in first layer of soil !! wshd_pstap(:)|kg/ha |total amount of pesticide type applied in @@ -96,16 +92,16 @@ subroutine apply xx = xx * ap_ef(kk) ! added for pesticide incorporation 3/31/08 gsm - if (pst_dep(npest(j),j) > 1.e-6) then + if (pst_dep > 1.e-6) then do nly = 1,sol_nly(j) if (nly == 1) then - if (pst_dep(npest(j),j) < sol_z(nly,j)) then + if (pst_dep < sol_z(nly,j)) then sol_pst(k,j,1) = sol_pst(k,j,1) + xx exit endif else - if (pst_dep(npest(j),j) > sol_z((nly-1),j) .and. & - & pst_dep(npest(j),j) < sol_z(nly,j)) then + if (pst_dep > sol_z((nly-1),j) .and. & + & pst_dep < sol_z(nly,j)) then sol_pst(k,j,nly) = sol_pst(k,j,nly) + xx exit endif @@ -131,8 +127,5 @@ subroutine apply & ap_ef(kk) * hru_dafr(j) end if -!! update sequence number for pesticide application - npest(j) = npest(j) + 1 - return end diff --git a/src/bmp_sand_filter.f b/src/bmp_sand_filter.f index 5ce038f..31772e6 100644 --- a/src/bmp_sand_filter.f +++ b/src/bmp_sand_filter.f @@ -322,8 +322,8 @@ subroutine sand_filter(kk,flw,sed) ft_sed_cumul(sb,kk) = ft_sed_cumul(sb,kk) + sed_removed !tons End if - write(*,'(3i6,20f10.3)') iyr,iida,ii,qin(ii), - & qout(ii),qsw(ii),qpnd(ii),qloss,qevap +! write(*,'(3i6,20f10.3)') iyr,iida,ii,qin(ii), +! & qout(ii),qsw(ii),qpnd(ii),qloss,qevap ! write(*,'(3i5,20f10.3)') iyr,iida,ii,precipdt(ii),qin(ii), ! & qout(ii),qloss,qpndi,qpnde,qpnd(ii),qsw(ii),f(ii),sed(1,ii)*1000, ! & sed(2,ii)*1000,sloss*1000 diff --git a/src/bmp_wet_pond.f b/src/bmp_wet_pond.f index 0bd9207..9e40ab4 100644 --- a/src/bmp_wet_pond.f +++ b/src/bmp_wet_pond.f @@ -59,9 +59,9 @@ subroutine wet_pond !! Estimate Pond Volume using Austin Design Manual if not entered by user !! COA Environmental Criteria Manual Chapter 1.6.6 and Table 1-9 if (wtp_dim(sb)==0) then - imc = subdr_ickm(sb) / subdr_km(sb) !fraction impervious cover + imc = subdr_ickm(ihout) / subdr_km(ihout) !fraction impervious cover rf = 0.5463 * imc ** 2 + 0.328 * imc + 0.0296 - wtp_pvol(sb) = 0.162 * rf * (subdr_km(sb) * 247.11) !ac-feet + wtp_pvol(sb) = 0.162 * rf * (subdr_km(ihout) * 247.11) !ac-feet wtp_pvol(sb) = wtp_pvol(sb) * 1233.4 !m3 if (wtp_pvol(sb)<3000) wtp_pvol(sb) = 3000. !minimum area 21780ft2 * depth 5ft gives ~3000m3 wtp_pdepth(sb) = 2. !m diff --git a/src/bmpinit.f b/src/bmpinit.f index 2f1f533..cf4ddae 100644 --- a/src/bmpinit.f +++ b/src/bmpinit.f @@ -63,9 +63,9 @@ subroutine bmpinit use parm implicit none integer :: k, eof,kk - real :: hwq,wqv,sub_ha,bmpfr + real :: hwq,wqv,sub_ha,bmpfr_sf,bmpfr_ri - eof = 0; bmpfr=0. + eof = 0; bmpfr_sf=0.; bmpfr_ri=0. sub_ha = sub_km(i) * 100. !! Detention pond @@ -135,29 +135,29 @@ subroutine bmpinit !fraction runoff that directly enters the channel if(num_sf(i)>=1) then do kk=1,num_sf(i) - bmpfr = bmpfr + sf_fr(i,kk) + bmpfr_sf = bmpfr_sf + sf_fr(i,kk) end do endif if(num_ri(i)>=1) then do kk=1,num_ri(i) - bmpfr = bmpfr + ri_fr(i,kk) + bmpfr_ri = bmpfr_ri + ri_fr(i,kk) end do endif - if (bmpfr>1) then + if (bmpfr_sf>1.or.bmpfr_ri>1) then write (*,*) " " write (*,*) "Urban BMP Warning!!" write (*,*) "In subbasin ", i write (*,*) "The fraction runoff draining to urban BMPs" write (*,*) " are larger than one, so the fraction values" - write (*,*) " were automatically corrected" + write (*,*) " were automatically reassigned" write (*,*) " " do kk=1,num_sf(i) - sf_fr(i,kk) = sf_fr(i,kk) / bmpfr + sf_fr(i,kk) = sf_fr(i,kk) / bmpfr_sf end do do kk=1,num_sf(i) - ri_fr(i,kk) = ri_fr(i,kk) / bmpfr + ri_fr(i,kk) = ri_fr(i,kk) / bmpfr_ri end do - bmpfr = 1. + bmpfr_sf = 1.; bmpfr_ri=1. endif !!Retention-Irrigation @@ -170,7 +170,7 @@ subroutine bmpinit !City of Austin Design Guideline 1.6.9.2 Table 1-12 !Retention-Irrigation for Barton Springs Zone - hwq = (1.8 * sub_ha_imp(i) / sub_ha + 0.6) !inches + hwq = (1.8 * sub_ha_imp(i) / sub_ha_urb(i) + 0.6) !inches wqv = hwq / 12. * sub_ha_urb(i) * ri_fr(i,k) * 107639.104167 !ft3 if (ri_dim(i,k)==0) then @@ -207,13 +207,13 @@ subroutine bmpinit if (ri_iy(i,k)==0) ri_iy(i,k) = iyr if (ri_im(i,k)==0) ri_im(i,k) = 1 - write(77779,'(a11,i5)') 'Subbasin #:', i ! bmp_sedfil.out - write(77779,'(a46)') '' - write(77779,'(a10,i5)') 'RI #:', K ! bmp_sedfil.out - write(77779,'(a17,f10.1,a4)') 'Total volume =', ri_vol(i,k),'m^3' - write(77779,'(a17,f10.1,a4)') 'Surface area =', ri_sa(i,k),'m^2' - write(77779,'(a17,f10.1,a3)') 'Drawdown time =', ri_dd (i,k),'hr' - write(77779,'(a17)') '' + write(77779,'(a11,i5)') 'Subbasin #:', i ! bmp_sedfil.out + write(77779,'(a46)') '' + write(77779,'(a10,i5)') 'RI #:', K ! bmp_sedfil.out + write(77779,'(a17,f10.1,a4)') 'Total volume =', ri_vol(i,k),'m^3' + write(77779,'(a17,f10.1,a4)') 'Surface area =', ri_sa(i,k),'m^2' + write(77779,'(a17,f10.1,a3)') 'Drawdown time =', ri_dd (i,k),'hr' + write(77779,'(a17)') '' end do @@ -226,7 +226,7 @@ subroutine bmpinit write(77778,'(a10,i5)') 'SED-FIL #:', K ! bmp_sedfil.out !determine water quality volume for defult pond sizes !City of Austin Design Guideline 1.6.2 - hwq = (0.5 + sub_ha_imp(i) / sub_ha - 0.2) !inches + hwq = (0.5 + sub_ha_imp(i) / sub_ha_urb(i) - 0.2) !inches wqv = hwq / 12. * sub_ha_urb(i) * sf_fr(i,k) * 107639.104167 !ft3 if (sf_dim(i,k)==0) then @@ -285,18 +285,16 @@ subroutine bmpinit !Orifice pipe for sand filter should be equal or larger than !sedimentation pond outlet pipe for full-type SedFils - if (sf_typ(i,k)==1) then - if (ft_pd(i,k) canstori) then - do ii = 1, 24 + do ii = 1, nstep xx = 0. - xx = hhprecip(ii) - hhprecip(ii) = hhprecip(ii) - (canstor(j) - canstori) + xx = precipdt(ii) + precipdt(ii) = precipdt(ii) - (canstor(j) - canstori) - if (hhprecip(ii) < 0.) then + if (precipdt(ii) < 0.) then canstori = canstori + xx - hhprecip(ii) = 0. + precipdt(ii) = 0. else canstori = canstor(j) endif diff --git a/src/carbon_zhang2.f90 b/src/carbon_zhang2.f90 new file mode 100644 index 0000000..aa3e268 --- /dev/null +++ b/src/carbon_zhang2.f90 @@ -0,0 +1,820 @@ + subroutine carbon_zhang2 + use parm + !!============================================ + !!Input variables + !! sol_bd(:,:) |Mg/m**3 |bulk density of the soil + !! sol_st(:,:) |mm H2O |amount of water stored in the soil layer on + !! |current day + !! sol_fc(:,:) |mm H2O |amount of water available to plants in soil + !! |layer at field capacity (fc - wp),Index:(layer,HRU) + !! sol_wp(:,:) |mm H20/mm soil|water content of soil at -1.5 MPa (wilting + !! |point) + !! sol_wpmm(:,:) |mm H20 |water content of soil at -1.5 MPa (wilting + !! |point) + !! sol_percc(k,j) + !! sol_latc(k,j) + !!============================================== + !!Transput variables; + !! sol_HSC(:,:) : mass of C present in slow humus (kg ha-1) + !! sol_HSN(:,:) : mass of N present in slow humus (kg ha-1) + !! sol_HPC(:,:) : mass of C present in passive humus (kg ha-1) + !! sol_HPN(:,:) : mass of N present in passive humus (kg ha-1) + !! sol_LM(:,:) : mass of metabolic litter (kg ha-1) + !! sol_LMC(:,: : mass of C in metabolic litter (kg ha-1) + !! sol_LMN(:,:) : mass of N in metabolic litter (kg ha-1) + !! sol_LS(:,:) : mass of structural litter (kg ha-1) + !! sol_LSC(:,:) : mass of C in structural litter (kg ha-1) + !! sol_LSL(:,:) : mass of lignin in structural litter (kg ha-1) + !! sol_LSN(:,:) : mass of N in structural litter (kg ha-1) + !! STD(:) : standing dead (kg ha-1) (Not used) + !! STDL(:) : mass of lignin in standing dead (kg ha-1) (Not used) + !! STDN(:) : mass of N in standing dead (dead plants + sorbed from soil; kg ha-1) (Not used) + !! STDNEl(:) : standing dead N after enrichment with sorbed N in a soil layer (kg ha-1) + !! sol_NO3(:,:) : weight of NO3-N in soil layer (kg ha-1) + !! sol_NH3(:,:) : weight of NH3-N in soil layer (kg ha-1) + + !!============================================== + !!read in parameters + !HPR : rate of transformation of passive humus under optimal conditions (subsurface + !layers = 0.000012 day-1) (Parton et al.,1993, 1994) + !HSR : rate of transformation of slow humus under optimal conditions (all layers + != 0.0005 day-1) (Parton et al., 1993, 1994; Vitousek et al., 1993) + !KOC : liquid–solid partition coefficient for microbial biomass (10^3 m^3 Mg-1) + !BMR : rate of transformation of microbial biomass and associated products under optimal + ! conditions (surface = 0.0164 day-1; all other layers = 0.02 day-1) (Parton et al., 1993, 1994) + !LMR : rate of transformation of metabolic litter under optimal conditions (surface = + !0.0405 day-1; all other layers = 0.0507 day-1) (Parton et al., 1994) + !Sf : fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for belowground litter + + !Cf : carbon fraction of organic materials 0.42; from data of Pinck et al., 1950) + !LSR : rate of potential transformation of structural litter under optimal conditions + !(surface = 0.0107 day-1; all other layers= 0.0132 day-1) (Parton et al., 1994) + !PRMT_51 !COEF ADJUSTS MICROBIAL ACTIVITY FUNCTION IN TOP SOIL LAYER (0.1_1.), + !PRMT_45 !COEF IN CENTURY EQ ALLOCATING SLOW TO PASSIVE HUMUS(0.001_0.05) ORIGINAL VALUE = 0.003, + + + !!============================================== + !! local variables + !ABCO2 : allocation from biomass to CO2; 0.6 (surface litter), 0.85–0.68*(CLAF + SILF) (all other layers) (Parton et al., 1993, 1994) + !ABL : carbon allocation from biomass to leaching; ABL = (1-exp(-f/(0.01* SW+ 0.1*(KdBM)*DB)) (Williams, 1995) + !ABP : allocation from biomass to passive humus; 0 (surface litter), 0.003 + 0.032*CLAF (all other layers) (Parton et al., 1993, 1994) + !ALMCO2 : allocation from metabolic litter to CO2; 0.6 (surface litter), 0.55 (all other layers) (Parton et al., 1993, 1994) + !ALSLCO2 : allocation from lignin of structural litter to CO2; 0.3 (Parton et al., 1993, 1994) + !ALSLNCO2: allocation from non-lignin of structural litter to CO2; 0.6 (surface litter), 0.55 (all other layers) (Parton et al., 1993, 1994) + !APCO2 : allocation from passive humus to CO2; 0.55 (Parton et al., 1993, 1994) + !ASCO2 : allocation from slow humus to CO2; 0.55 (Parton et al., 1993, 1994) + !ASP : allocation from slow humus to passive; 0 (surface litter), 0.003-0.009*CLAF (all other layers) (Parton et al., 1993, 1994) + !BMC : mass of C in soil microbial biomass and associated products (kg ha-1) + !BMCTP : potential transformation of C in microbial biomass (kg ha-1 day-1) + !BMN : mass of N in soil microbial biomass and associated products (kg ha-1) + !BMNTP : potential transformation of N in microbial biomass (kg ha-1 day-1) + + !CDG : soil temperature control on biological processes + !CNR : C/N ratio of standing dead + !CS : combined factor controlling biological processes [CS = sqrt(CDG×SUT)* 0.8*OX*X1), CS < 10; CS = 10, CS>=10 (Williams, 1995)] + !DBp : soil bulk density of plow layer (Mg m-3) (Not used) + !HSCTP : potential transformation of C in slow humus (kg ha-1 day-1) + !HSNTP : potential transformation of N in slow humus (kg ha-1 day-1) + !HPCTP : potential transformation of C in passive humus (kg ha-1 day-1) + !HPNTP : potential transformation of N in passive humus (kg ha-1 day-1) + !LMF : fraction of the litter that is metabolic + !LMNF : fraction of metabolic litter that is N (kg kg-1) + !LMCTP : potential transformation of C in metabolic litter (kg ha-1 day-1) + !LMNTP : potential transformation of N in metabolic litter (kg ha-1 day-1) + !LSCTP : potential transformation of C in structural litter (kg ha-1 day-1) + !LSF : fraction of the litter that is structural + !LSLF : fraction of structural litter that is lignin (kg kg-1) + !LSNF : fraction of structural litter that is N (kg kg-1) + !LSLCTP : potential transformation of C in lignin of structural litter (kg ha-1 day-1) + !LSLNCTP : potential transformation of C in nonlignin structural litter (kg ha-1 day-1) + !LSNTP : potential transformation of N in structural litter (kg ha-1 day-1) + !NCBM : N/C ratio of biomass + !NCHP : N/C ratio passive humus + !NCHS : N/C ratio of the slow humus + !OX : oxygen control on biological processes with soil depth + !SUT : soil water control on biological processes + !X1 : tillage control on residue decomposition (Not used) + !XBMT : control on transformation of microbial biomass by soil texture and structure. + !Its values: surface litter layer = 1; all other layers = 1-0.75*(SILF + CLAF) (Parton et al., 1993, 1994) + !XLSLF : control on potential transformation of structural litter by lignin fraction + !of structural litter [XLSLF = exp(-3* LSLF) (Parton et al., 1993, 1994)] + integer :: j, k, kk + real :: sol_mass, sol_min_n + real :: fc, wc, sat, void, sut, cdg, OX, CS + real :: X1,X3, XX + real :: LMF, LSF, LSLF, XLSLF, LSR, BMR, XBMT, HSR, HPR + real :: LSCTA, LSLCTA, LSLNCTA,LSNTA, LMCTA, LMNTA, BMCTA, BMNTA, HSCTA, HSNTA, HPCTA, HPNTA + real :: LSCTP, LSLCTP, LSLNCTP, LSNTP, LMR, LMCTP, LMNTP, BMCTP,HSCTP, HSNTP, HPCTP, HPNTP + real :: NCHP, Nf, NCBM, NCHS, ALSLCO2, ALSLNCO2,ALMCO2,ABCO2, A1CO2, APCO2, ASCO2, ABP, ASP, A1, ASX, APX + real :: PRMT_51, PRMT_45 + real :: DF1, DF2, SNMN, DF3, DF4, DF5, DF6, ADD, ADF1, ADF2, ADF3, ADF4, ADF5 + real :: TOT + real :: PN1, PN2, PN3, PN4, PN5, PN6, PN7, PN8, PN9 + real :: SUM, CPN1, CPN2, CPN3, CPN4, CPN5 + real :: WMIN,DMDN, wdn, Delta_BMC, DeltaWN + !! initilize local variables + DeltaWN = 0. + DeltaBMC = 0. + wdn = 0. + X1 = 0. + X3 = 0. + XX = 0. + fc = 0. + wc = 0. + sat = 0. + void = 0. + sut = 0. + cdg = 0. + OX = 0. + CS = 0. + LMF = 0. + LSF = 0. + LSLF = 0. + XLSLF = 0. + LSR = 0. + LSCTP = 0. + LSCTA = 0. + LSLCTA = 0. + LSLNCTA = 0. + SNTA = 0. + LMCTA = 0. + LMNTA = 0. + BMCTA = 0. + BMNTA = 0. + HSCTA = 0. + HSNTA= 0. + HPCTA= 0. + HPNTA= 0. + LSLCTP= 0. + LSLNCTP= 0. + LSNTP= 0. + LMR= 0. + LMCTP= 0. + LMNTP= 0. + BMR= 0. + XBMT= 0. + BMCTP= 0. + HSR= 0. + HSCTP= 0. + HSNTP= 0. + HPR= 0. + HPCTP= 0. + HPNTP= 0. + NCHP= 0. + Nf= 0. + NCBM= 0. + NCHS= 0. + ALSLCO2= 0. + ALSLNCO2= 0. + ALMCO2= 0. + ABCO2= 0. + A1CO2= 0. + APCO2= 0. + ASCO2= 0. + ABP= 0. + ASP= 0. + A1= 0. + ASX= 0. + APX= 0. + DF1= 0. + DF2= 0. + SNMN= 0. + DF3= 0. + DF4= 0. + DF5= 0. + DF6= 0. + ADD= 0. + ADF1= 0. + ADF2= 0. + ADF3= 0. + ADF4= 0. + ADF5= 0. + PN1= 0. + PN2= 0. + PN3= 0. + PN4= 0. + PN5= 0. + PN6= 0. + PN7= 0. + PN8= 0. + PN9= 0. + TOT= 0. + SUM= 0. + CPN1= 0. + CPN2= 0. + CPN3= 0. + CPN4= 0. + CPN5= 0. + WMIN= 0. + DMDN= 0. + + j=0 + j=ihru + + do k = 1,sol_nly(j) + ! a simple equation to calculate Bulk Density from DSSAT (Not Used) + !XZ = sol_cbn(k,j) + !sol_BDM(k)=ZZ/(1./BD(J)-XZ/.224) + end do + + !!for debug purpose by zhang + if (iyr == 1941 .and. i==134) then + !write(*,*) 'stop' + end if + + !calculate tillage factor using DSSAT + if (tillage_switch(j) .eq. 1 .and. tillage_days(j) .le. 30) then + tillage_factor(j) = 1.6 + else + tillage_factor(j) = 1.0 + end if + !calculate tillage factor using DSSAT + + + !!calculate C/N dynamics for each soil layer + !!=========================================== + do k = 1, sol_nly(j) + if (k == 1) then + !10 cm / 1000 = 0.01m; 1 ha = 10000 m2; ton/m3; * 1000 --> final unit is kg/ha; rock fraction is considered + sol_mass = (10) / 1000.* 10000. * sol_bd(k,j)* 1000. *(1- sol_rock(k,j) / 100.) + else + sol_mass = (sol_z(k,j) - sol_z(k-1,j)) / 1000.* 10000. * sol_bd(k,j)* 1000. *(1- sol_rock(k,j) / 100.) + end if + + !!If k = 1, then using temperature, soil moisture in layer 2 to calculate decomposition factor + !!Not + kk =0 + if (k == 1) then + kk = 2 + else + kk = k + end if + !! mineralization can occur only if temp above 0 deg + !check sol_st soil water content in each soil ayer mm H2O + if (sol_tmp(k,j) > 0. .AND. sol_st(k,j) > 0.) then + !!from Armen + !!compute soil water factor - sut + fc = sol_fc(k,j) + sol_wpmm(k,j) ! units mm + wc = sol_st(k,j) + sol_wpmm(k,j) ! units mm + sat = sol_ul(k,j) + sol_wpmm(k,j) ! units mm + void = sol_por(k,j) * (1. - wc / sat) ! fraction + !!from Armen + + sut = 0. + !sut = .1 + .9 * Sqrt(sol_st(kk,j) / sol_fc(kk,j)) + !sut = .1 + .9 * Sqrt(wc / fc) + + X1=wc-sol_wpmm(k,j) + IF(X1<0.)THEN + SUT=.1*(sol_st(kk,j) /sol_wpmm(k,j))**2 + ELSE + SUT = .1 + .9 * Sqrt(sol_st(k,j) / sol_fc(k,j)) + END IF + sut = Min(1., sut) + sut = Max(.05, sut) + !check X1, FC, S15 + + !from Armen + !wf = fwf(fc,wc,sol_wpmm(kk,j)) + !of = fof(void,sol_por(kk,j)) + !sut = wf * of + !from Armen + + !!compute tillage factor (X1) + !use the tillfactor module from Armen + !X1 = ftilf(tillagef(kk,j), wc, sat) + X1 = 1.0 + + !calculate tillage factor using DSSAT + if (tillage_switch(j) .eq. 1 .and. tillage_days(j) .le. 30) then + if (k == 1) then + X1 = 1.6 + else + if (sol_z(k,j) .le. tillage_depth(j)) then + X1 = 1.6 + elseif (sol_z(k-1,j) .lt. tillage_depth(j)) then + X1 = 1.0 + 0.6*(tillage_depth(j) - sol_z(k-1,j))/(sol_z(k,j) - sol_z(k-1,j)) + end if + end if + else + X1 = 1.0 + end if + !calculate tillage factor using DSSAT + + !!compute soil temperature factor + !!When sol_tep is larger than 35, cdg is negative? + cdg = 0. + !if (sol_tmp(kk,j) <= 35.0) then + !cdg = sol_tmp(kk,j) / (sol_tmp(kk,j) + exp(5.058 - 0.2504 * sol_tmp(kk,j))) + cdg = sol_tmp(k,j) / (sol_tmp(k,j) + exp(5.058459 - 0.2503591 * sol_tmp(k,j))) + + !end if + + !!from Armen + cdg = fcgd(sol_tmp(k,j)) + !!from Armen + + !!compute oxygen (OX) + OX = 0. + !OX = 1 - (0.9* sol_z(k,j)/1000.) / (sol_z(k,j)/1000.+ exp(1.50-3.99*sol_z(k,j)/1000.)) + !OX = 1 - (0.8* sol_z(k,j)) / (sol_z(k,j)+ exp(1.50-3.99*sol_z(k,j))) + OX=1.-0.8*((sol_z(kk,j)+sol_z(kk-1,j))/2)/(((sol_z(kk,j)+sol_z(kk-1,j))/2)+EXP(18.40961-0.023683632*((sol_z(kk,j)+sol_z(kk-1,j))/2))) + !! compute combined factor + CS = 0. + CS=MIN(10.,SQRT(cdg*sut)*0.9*OX*X1) + !! call denitrification (to use void and cdg factor) + wdn = 0. + cdg = fcgd(sol_tmp(k,j)) + if (cdg > 0. .and. void <= 0.1) then + call ndenit(k,j,cdg,wdn,void) + end if + wshd_dnit = wshd_dnit + wdn * hru_dafr(j) + wdntl = wdntl + wdn + + + + sol_min_n = sol_no3(k,j) + sol_nh3(k,j) + + + !lignin content in structural litter (fraction) + RLR = 0. + RLR = min(0.8,sol_LSL(k,j)/(sol_LS(k,j) + 1.E-5)) + + !HSR=PRMT(47) !CENTURY SLOW HUMUS TRANSFORMATION RATE D^-1(0.00041_0.00068) ORIGINAL VALUE = 0.000548, + HSR = 5.4799998E-04 + !HPR=PRMT(48) !CENTURY PASSIVE HUMUS TRANSFORMATION RATE D^-1(0.0000082_0.000015) ORIGINAL VALUE = 0.000012 + HPR = 1.2000000E-05 + + APCO2=.55 + ASCO2=.60 + PRMT_51 =0. !COEF ADJUSTS MICROBIAL ACTIVITY FUNCTION IN TOP SOIL LAYER (0.1_1.), + PRMT_51 = 1. + !!The following codes are clculating of the N:C ration in the newly formed SOM for each pool + !!please note that in the surface layer, no new materials enter Passive pool, therefore, no NCHP is + !!calculated for the first layer. + IF(k==1)THEN + CS=CS*PRMT_51 + ABCO2=.55 + A1CO2=.55 + BMR=.0164 + LMR=.0405 + LSR=.0107 + NCHP=.1 + XBM=1. + ! COMPUTE N/C RATIOS + !X1=.1*(WLMN(LD1)+WLSN(LD1))/(RSD(LD1)+1.E-5) + X1 = 0.1*(sol_LSN(k,j)+sol_LMN(k,j))/(sol_rsd(k,j)/1000+1.E-5) !relative notrogen content in residue (%) + IF(X1>2.)THEN + NCBM=.1 + GO TO 6 + END IF + IF(X1>.01)THEN + NCBM=1./(20.05-5.0251*X1) + ELSE + NCBM=.05 + END IF + 6 NCHS=NCBM/(5.*NCBM+1.) + GO TO 2 + END IF + !ABCO2=.17+.0068*SAN(ISL) + ABCO2 = 0.17 + 0.0068 * sol_sand(k,j) + A1CO2=.55 + BMR=.02 + LMR=.0507 + LSR=.0132 + XBM=.25+.0075*sol_sand(k,j) + !X1=1000.*(WNH3(ISL)+WNO3(ISL))/WT(ISL) + !WT is soil mass in tons + X1 = 1000. * sol_min_n/(sol_mass/1000) + IF(X1>7.15)THEN + NCBM=.33 + NCHS=.083 + NCHP=.143 + ELSE + NCBM=1./(15.-1.678*X1) + NCHS=1./(20.-1.119*X1) + NCHP=1./(10.-.42*X1) + END IF + 2 ABP=.003+.00032*sol_clay(k,j) + !SMS(3,ISL)=SMS(3,ISL)+CS + PRMT_45 = 0. !COEF IN CENTURY EQ ALLOCATING SLOW TO PASSIVE HUMUS(0.001_0.05) ORIGINAL VALUE = 0.003, + PRMT_45 = 5.0000001E-02 + ASP=MAX(.001,PRMT_45-.00009*sol_clay(k,j)) + ! POTENTIAL TRANSFORMATIONS STRUCTURAL LITTER + X1=LSR*CS*EXP(-3.*RLR) + LSCTP=X1*sol_LSC(k,j) + LSLCTP=LSCTP*RLR + LSLNCTP=LSCTP*(1.-RLR) + LSNTP=X1*sol_LSN(k,j) + ! POTENTIAL TRANSFORMATIONS METABOLIC LITTER + X1=LMR*CS + LMCTP=sol_LMC(k,j)*X1 + LMNTP=sol_LMN(k,j)*X1 + ! POTENTIAL TRANSFORMATIONS MICROBIAL BIOMASS + X1=BMR*CS*XBM + BMCTP=sol_BMC(k,j)*X1 + BMNTP=sol_BMN(k,j)*X1 + ! POTENTIAL TRANSFORMATIONS SLOW HUMUS + X1=HSR*CS + HSCTP=sol_HSC(k,j)*X1 + HSNTP=sol_HSN(k,j)*X1 + ! POTENTIAL TRANSFORMATIONS PASSIVE HUMUS + X1=CS*HPR + HPCTP=sol_HPC(k,j)*X1 + HPNTP=sol_HPN(k,j)*X1 + ! ESTIMATE N DEMAND + A1=1.-A1CO2 + ASX=1.-ASCO2-ASP + APX=1.-APCO2 + + PN1=LSLNCTP*A1*NCBM !Structural Litter to Biomass + PN2=.7*LSLCTP*NCHS !Structural Litter to Slow + PN3=LMCTP*A1*NCBM !Metabolic Litter to Biomass + !PN4=BMCTP*ABL*NCBM !Biomass to Leaching (calculated in NCsed_leach) + PN5=BMCTP*ABP*NCHP !Biomass to Passive + PN6=BMCTP*(1.-ABP-ABCO2)*NCHS !Biomass to Slow + PN7=HSCTP*ASX*NCBM !Slow to Biomass + PN8=HSCTP*ASP*NCHP !Slow to Passive + PN9=HPCTP*APX*NCBM !Passive to Biomass + + !PN1=LSLNCTP*A1*NCBM + !PN2=.7*LSLCTP*NCHS + !PN3=LMCTP*A1*NCBM + !PN5=BMCTP*ABP*NCHP + !PN6=BMCTP*(1.-ABP-ABCO2)*NCHS + !PN7=HSCTP*ASX*NCBM + !PN8=HSCTP*ASP*NCHP + !PN9=HPCTP*APX*NCBM + ! COMPARE SUPPLY AND DEMAND FOR N + SUM=0. + CPN1=0. + CPN2=0. + CPN3=0. + CPN4=0. + CPN5=0. + X1=PN1+PN2 + IF(LSNTP0.)THEN + LSCTA=LSCTP*X3 + LSNTA=LSNTP*X3 + LSLCTA=LSLCTP*X3 + LSLNCTA=LSLNCTP*X3 + ELSE + LSCTA=LSCTP + LSNTA=LSNTP + LSLCTA=LSLCTP + LSLNCAT=LSLNCTP + END IF + IF(CPN2>0.)THEN + LMCTA=LMCTP*X3 + LMNTA=LMNTP*X3 + ELSE + LMCTA=LMCTP + LMNTA=LMNTP + END IF + IF(CPN3>0.)THEN + BMCTA=BMCTP*X3 + BMNTA=BMNTP*X3 + ELSE + BMCTA=BMCTP + BMNTA=BMNTP + END IF + IF(CPN4>0.)THEN + HSCTA=HSCTP*X3 + HSNTA=HSNTP*X3 + ELSE + HSCTA=HSCTP + HSNTA=HSNTP + END IF + IF(CPN5>0.)THEN + HPCTA=HPCTP*X3 + HPNTA=HPNTP*X3 + ELSE + HPCTA=HPCTP + HPNTA=HPNTP + END IF + + !Recalculate demand using actural transformations + !revised from EPIC code by Zhang + PN1=LSLNCTA*A1*NCBM !Structural Litter to Biomass + PN2=.7*LSLCTA*NCHS !Structural Litter to Slow + PN3=LMCTA*A1*NCBM !Metabolic Litter to Biomass + !PN4=BMCTP*ABL*NCBM !Biomass to Leaching (calculated in NCsed_leach) + PN5=BMCTA*ABP*NCHP !Biomass to Passive + PN6=BMCTA*(1.-ABP-ABCO2)*NCHS !Biomass to Slow + PN7=HSCTA*ASX*NCBM !Slow to Biomass + PN8=HSCTA*ASP*NCHP !Slow to Passive + PN9=HPCTA*APX*NCBM !Passive to Biomass + ! COMPARE SUPPLY AND DEMAND FOR N + SUM=0. + CPN1=0. + CPN2=0. + CPN3=0. + CPN4=0. + CPN5=0. + X1=PN1+PN2 + IF(LSNTA0.)THEN + sol_NH3(k,j)=sol_NH3(k,j)+sol_RNMN(k,j) + ! WNO3(ISL)=WNO3(ISL)+RNMN(ISL) + GO TO 21 + END IF + X1=sol_NO3(k,j)+sol_RNMN(k,j) + IF(X1<0.)THEN + sol_RNMN(k,j)=-sol_NO3(k,j) + sol_NO3(k,j)=1.E-10 + ELSE + sol_NO3(k,j)=X1 + END IF + 21 DF1=LSNTA + + DF2=LMNTA + !!DF represents Demand from + !SNMN=SNMN+sol_RNMN(k,j) + + !calculate P flows + !! compute humus mineralization on active organic p + hmp = 0. + hmp_rate = 0. + hmp_rate = 1.4* (HSNTA + HPNTA)/(sol_HSN(k,j) + sol_HPN(k,j) + 1.e-6) + !hmp_rate = 1.4* (HSNTA )/(sol_HSN(k,j) + sol_HPN(k,j) + 1.e-6) + hmp = hmp_rate*sol_orgp(k,j) + hmp = Min(hmp, sol_orgp(k,j)) + sol_orgp(k,j) = sol_orgp(k,j) - hmp + sol_solp(k,j) = sol_solp(k,j) + hmp + + !! compute residue decomp and mineralization of + !! fresh organic n and p (upper two layers only) + rmp = 0. + decr = 0. + decr = (LSCTA + LMCTA)/(sol_LSC(k,j) + sol_LMC(k,j) + 1.e-6) + decr = min(1., decr) + rmp = decr * sol_fop(k,j) + + sol_fop(k,j) = sol_fop(k,j) - rmp + sol_solp(k,j) = sol_solp(k,j) + .8 * rmp + sol_orgp(k,j) = sol_orgp(k,j) + .2 * rmp + !calculate P flows + + + !SMS(9,ISL)=SMS(9,ISL)+RNMN(ISL) + LSCTA = Min(sol_LSC(k,j),LSCTA) + sol_LSC(k,j)=MAX(1.E-10,sol_LSC(k,j)-LSCTA) + LSLCTA = min(sol_LSLC(k,j),LSLCTA) + sol_LSLC(k,j)=MAX(1.E-10,sol_LSLC(k,j)-LSLCTA) + sol_LSLNC(k,j)=MAX(1.E-10,sol_LSLNC(k,j)-LSLNCTA) + LMCTA=MIN(sol_LMC(k,j),LMCTA) + IF (sol_LM(k,j) > 0.) THEN + RTO = MAX(0.42,sol_LMC(k,j)/sol_LM(k,j)) + sol_LM(k,j) = sol_LM(k,j) - LMCTA/RTO + sol_LMC(k,j) = sol_LMC(k,j) - LMCTA + END IF + !sol_LMC(k,j)=MAX(1.E-10,sol_LMC(k,j)-LMCTA) + !sol_LM(k,j)=MAX(1.E-10,sol_LM(k,j)-LMCTA/.42) + sol_LSL(k,j)=MAX(1.E-10,sol_LSL(k,j)-LSLCTA/.42) + sol_LS(k,j)=MAX(1.E-10,sol_LS(k,j)-LSCTA/.42) + + X3=APX*HPCTA+ASX*HSCTA+A1*(LMCTA+LSLNCTA) + sol_BMC(k,j)=sol_BMC(k,j)-BMCTA+X3 + !DeltaBMC = DeltaBMC -BMCTA+X3 + DF3=BMNTA-NCBM*X3 + !!DF3 is the supply of BMNTA - demand of N to meet the Passive, Slow, Metabolic, and Non-lignin Structural + !! C pools transformaitons into microbiomass pool + X1=.7*LSLCTA+BMCTA*(1.-ABP-ABCO2) + sol_HSC(k,j)=sol_HSC(k,j)-HSCTA+X1 + DF4=HSNTA-NCHS*X1 + !!DF4 Slow pool supply of N - N demand for microbiomass C transformed into slow pool + X1=HSCTA*ASP+BMCTA*ABP + sol_HPC(k,j)=sol_HPC(k,j)-HPCTA+X1 + DF5=HPNTA-NCHP*X1 + !!DF5 Passive pool demand of N - N demand for microbiomass C transformed into passive pool + DF6=sol_min_n-sol_NO3(k,j)-sol_NH3(k,j) + !!DF6 Supply of mineral N - available mineral N = N demanded from mineral pool + !SMS(10,ISL)=SMS(10,ISL)-DF6 + ADD=DF1+DF2+DF3+DF4+DF5+DF6 + ADF1=ABS(DF1) + ADF2=ABS(DF2) + ADF3=ABS(DF3) + ADF4=ABS(DF4) + ADF5=ABS(DF5) + TOT=ADF1+ADF2+ADF3+ADF4+ADF5 + XX=ADD/(TOT+1.E-10) + sol_LSN(k,j)=MAX(.001,sol_LSN(k,j)-DF1+XX*ADF1) + sol_LMN(k,j)=MAX(.001,sol_LMN(k,j)-DF2+XX*ADF2) + sol_BMN(k,j)=sol_BMN(k,j)-DF3+XX*ADF3 + sol_HSN(k,j)=sol_HSN(k,j)-DF4+XX*ADF4 + sol_HPN(k,j)=sol_HPN(k,j)-DF5+XX*ADF5 + sol_RSPC(k,j)=.3*LSLCTA+A1CO2*(LSLNCTA+LMCTA)+ABCO2*BMCTA+ASCO2*HSCTA+APCO2*HPCTA + rspc_d(j) = rspc_d(j) + sol_RSPC(k,j) + !SMM(74,MO)=SMM(74,MO)+RSPC(ISL) + !SMS(8,ISL)=SMS(8,ISL)+RSPC(ISL) + !TRSP=TRSP+RSPC(ISL) + !VAR(74)=VAR(74)+RSPC(ISL) + !RSD(ISL)=.001*(WLS(ISL)+WLM(ISL)) + sol_rsd(k,j)= sol_LS(k,j)+sol_LM(k,j) + sol_orgn(k,j) = sol_HPN(k,j) + sol_aorgn(k,j) = sol_HSN(k,j) + sol_fon(k,j) = sol_LMN(k,j) + sol_LSN(k,j) + sol_cbn(k,j) = 100*(sol_LSC(k,j)+sol_LMC(k,j) +sol_HSC(k,j) + sol_HPC(k,j) + sol_BMC(k,j))/sol_mass + + + +!! septic changes 1/28/09 gsm +!! compute denitrification while simulating septic tank + !wdn = 0. + !if (i_sep(j) /= k .and. ipop_sep(j) > 0) then + !! compute soil water factor + ! sut = 0. + !! change for domain error 1/29/09 gsm check with Jeff !!! + ! if (sol_st(kk,j) < 0.) sol_st(kk,j) = .0000001 + ! sut = .1 + .9 * Sqrt(sol_st(kk,j) / sol_fc(kk,j)) + ! sut = Min(1., sut) + ! sut = Max(.05, sut) + ! !!compute soil temperature factor + ! xx = 0. + ! cdg = 0. + ! xx = sol_tmp(kk,j) + ! cdg = .9 * xx / (xx + Exp(9.93 - .312 * xx)) + .1 + ! cdg = Max(.1, cdg) + + ! if (sut >= sdnco) then + ! wdn = sol_no3(k,j) * (1. - Exp(-cdn * cdg * sol_cbn(k,j))) + ! else + ! wdn = 0. + ! endif + ! sol_no3(k,j) = sol_no3(k,j) - wdn + !end if +! septic changes 1/28/09 gsm +!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! hmntl |kg N/ha |amount of nitrogen moving from active +!! |organic to nitrate pool in soil profile +!! |on current day in HRU +!! hmptl |kg P/ha |amount of phosphorus moving from the +!! |organic to labile pool in soil profile +!! |on current day in HRU +!! rmn2tl |kg N/ha |amount of nitrogen moving from the fresh +!! |organic (residue) to the nitrate(80%) and +!! |active organic(20%) pools in soil profile +!! |on current day in HRU +!! rmptl |kg P/ha |amount of phosphorus moving from the +!! |fresh organic (residue) to the labile(80%) +!! |and organic(20%) pools in soil profile +!! |on current day in HRU +!! rwntl |kg N/ha |amount of nitrogen moving from active +!! |organic to stable organic pool in soil +!! |profile on current day in HRU +!! sol_aorgn(:,:)|kg N/ha |amount of nitrogen stored in the active +!! |organic (humic) nitrogen pool +!! sol_fon(:,:) |kg N/ha |amount of nitrogen stored in the fresh +!! |organic (residue) pool +!! sol_fop(:,:) |kg P/ha |amount of phosphorus stored in the fresh +!! |organic (residue) pool +!! sol_no3(:,:) |kg N/ha |amount of nitrogen stored in the +!! |nitrate pool in soil layer +!! sol_orgn(:,:) |kg N/ha |amount of nitrogen stored in the stable +!! |organic N pool +!! sol_orgp(:,:) |kg P/ha |amount of phosphorus stored in the organic +!! |P pool in soil layer +!! sol_rsd(:,:) |kg/ha |amount of organic matter in the soil +!! |classified as residue +!! sol_solp(:,:) |kg P/ha |amount of phosohorus stored in solution +!! wdntl |kg N/ha |amount of nitrogen lost from nitrate pool +!! |by denitrification in soil profile on +!! |current day in HRU +!! wshd_dnit |kg N/ha |average annual amount of nitrogen lost from +!! |nitrate pool due to denitrification in +!! |watershed +!! wshd_hmn |kg N/ha |average annual amount of nitrogen moving +!! |from active organic to nitrate pool in +!! |watershed +!! wshd_hmp |kg P/ha |average annual amount of phosphorus moving +!! |from organic to labile pool in watershed +!! wshd_rmn |kg N/ha |average annual amount of nitrogen moving +!! |from fresh organic (residue) to nitrate +!! |and active organic pools in watershed +!! wshd_rmp |kg P/ha |average annual amount of phosphorus moving +!! |from fresh organic (residue) to labile +!! |and organic pools in watershed +!! wshd_rwn |kg N/ha |average annual amount of nitrogen moving +!! |from active organic to stable organic pool +!! |in watershed +! call ndenit(k,j,cdg,wdn,0.05) + !! end if + + !! summary calculations + !! calculations are based on century model, and not alighned with SWAT old algorithm yet. + if (curyr > nyskip) then + hmn = 0. + hmn = sol_RNMN(k,j) + wshd_hmn = wshd_hmn + hmn * hru_dafr(j) + rwn = 0. + rwn = HSNTA + wshd_rwn = wshd_rwn + rwn * hru_dafr(j) + + wshd_hmp = wshd_hmp + hmp * hru_dafr(j) + rmn1 = 0. + rmn1 = (LSNTA+LMNTA) + wshd_rmn = wshd_rmn + rmn1 * hru_dafr(j) + wshd_rmp = wshd_rmp + rmp * hru_dafr(j) + wshd_dnit = wshd_dnit + wdn * hru_dafr(j) + hmntl = hmntl + hmn + rwntl = rwntl + rwn + hmptl = hmptl + hmp + rmn2tl = rmn2tl + rmn1 + rmptl = rmptl + rmp + wdntl = wdntl + wdn + end if + + + + + end if + + end do + + !write (*,*) iyr,i, DeltaBMC + !write (*,*) iyr,i, wdntl + return + end + diff --git a/src/cfactor.f b/src/cfactor.f new file mode 100644 index 0000000..c66f5ea --- /dev/null +++ b/src/cfactor.f @@ -0,0 +1,92 @@ + subroutine cfactor + +!! ~ ~ ~ PURPOSE ~ ~ ~ +!! this subroutine predicts daily soil loss caused by water erosion +!! using the modified universal soil loss equation + +!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! cvm(:) |none |natural log of USLE_C (the minimum value +!! |of the USLE C factor for the land cover) +!! hru_km(:) |km**2 |area of HRU in square kilometers +!! icr(:) |none |sequence number of crop grown within a year +!! idplt(:,:,:)|none |land cover code from crop.dat +!! ihru |none |HRU number +!! iwave |none |flag to differentiate calculation of HRU and +!! |subbasin sediment calculation +!! |iwave = 0 for HRU +!! |iwave = subbasin # for subbasin +!! nro(:) |none |sequence number of year in rotation +!! peakr |m^3/s |peak runoff rate +!! rsd_covco | |residue cover factor for computing fraction of +!! cover +!! sno_hru(:) |mm H2O |amount of water in snow in HRU on current day +!! sol_cov(:) |kg/ha |amount of residue on soil surface +!! sub_km(:) |km^2 |area of subbasin in square kilometers +!! sub_qd(:) |mm H2O |surface runoff loading from subbasin for day +!! surfq(:) |mm H2O |surface runoff for the day in HRU +!! usle_ei |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index +!! usle_mult(:)|none |product of USLE K,P,LS,exp(rock) +!! wcklsp(:) | +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! cklsp(:) | +!! sedyld(:) |metric tons |daily soil loss caused by water erosion +!! usle |metric tons/ha|daily soil loss predicted with USLE equation +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! c | +!! j |none |HRU number +!! bio_frcov | |fraction of cover by biomass - adjusted for +!! canopy height +!! grcov_fr | |fraction of cover by biomass as function of lai +!! rsd_frcov | |fraction of cover by residue +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ +!! Intrinsic: Exp + +!! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ + + use parm + + integer :: j + real :: c + + j = 0 + j = ihru + + !! initialize variables + c = 0. + + !! HRU sediment calculations + if (icfac == 0) then + if (idplt(j) > 0) then + c = Exp((-.2231 - cvm(idplt(j))) * & + & Exp(-.00115 * sol_cov(j)) + cvm(idplt(j))) + else + if (sol_cov(j) > 1.e-4) then + c = Exp(-.2231 * Exp(-.00115 * sol_cov(j))) + else + c = .8 + end if + end if + else + rsd_frcov = Exp(-rsd_covco * sol_cov(j)) + grcov_fr = laiday(j) / (laiday(j) + + * Exp(1.748 - 1.748*laiday(j))) + bio_frcov = 1. - grcov_fr * Exp(-.01*cht(j)) + c = amax1(1.e-10,rsd_frcov*bio_frcov) + end if + + usle_cfac(ihru) = c + + return + end diff --git a/src/clgen.f b/src/clgen.f index 3ec2bd2..1f4a350 100644 --- a/src/clgen.f +++ b/src/clgen.f @@ -59,7 +59,7 @@ subroutine clgen(j) integer, intent (in) :: j integer :: ii - real :: sd, ch, h, ys, yc, dd, w, cosrho(24), totrho + real :: sd, ch, h, ys, yc, dd, w, cosrho(nstep), totrho !! Reset prior day category for precipitation if (subp(j) >= 0.1) then @@ -113,19 +113,19 @@ subroutine clgen(j) cosrho = 0. totrho = 0. - do ii = 1, 24 + do ii = 1, nstep !!angular velocity times hour away from solar noon. To calculate !!radiation for an hour, the hour angle for the midpoint of the !!time period is used. time = 0. at solar noon with positive values !! in the morning and negative in the evening w = 0. - w = (12.5 - Real(ii)) * 0.2618 !!0.2618 rad/hr + w = (12.5 - Real(ii)) * 0.2618 * idt / 60. !!0.2618 rad/hr cosrho(ii) = ys + yc * Cos(w) if (cosrho(ii) <= 0.) cosrho(ii) = 0. totrho = totrho + cosrho(ii) end do if (totrho > 0.001) then - do ii = 1, 24 + do ii = 1, nstep frad(j,ii) = cosrho(ii) / totrho end do end if diff --git a/src/clicon.f b/src/clicon.f index 8077100..aad7323 100644 --- a/src/clicon.f +++ b/src/clicon.f @@ -80,8 +80,6 @@ subroutine clicon !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! frad(:,:) |none |fraction of solar radiation occuring during !! |hour in day in HRU -!! hhsubp(:,:) |mm H2O |precipitation falling during hour in day in -!! |HRU !! hru_ra(:) |MJ/m^2 |solar radiation for the day in HRU !! hru_rmx(:) |MJ/m^2 |maximum solar radiation for the day in HRU !! ifirstpet |none |potential ET data search code @@ -140,7 +138,7 @@ subroutine clicon integer :: k, inum3sprev, npcpbsb, ii, iyp, idap, ib real :: tmxbsb, tmnbsb, rbsb, rhdbsb, rabsb, u10bsb, rmxbsb - real :: daylbsb, fradbsb(24), tdif, pdif, ratio + real :: daylbsb, fradbsb(nstep),tdif, pdif, ratio ! real, dimension (:), allocatable :: rhrbsb, rstpbsb ! if (nstep > 0) then ! allocate (rstpbsb(nstep)) @@ -191,9 +189,6 @@ subroutine clicon if (pcpsim == 2) then subp(k) = rbsb if (ievent > 1) then - do l = 1, 24 - hhsubp(k,l) = rhrbsb(l) - end do do l = 1, nstep rainsub(k,l) = rstpbsb(l) end do @@ -205,7 +200,7 @@ subroutine clicon hru_rmx(k) = rmxbsb dayl(k) = daylbsb npcp(k) = npcpbsb - do ii = 1, 24 + do ii = 1, nstep frad(k,ii) = fradbsb(ii) end do end if @@ -241,11 +236,7 @@ subroutine clicon tmnbsb = tmn(k) rbsb = subp(k) if (ievent > 1) then - rhrbsb = 0. rstpbsb = 0. - do l = 1, 24 - rhrbsb(l) = hhsubp(k,l) - end do do l = 1, nstep rstpbsb(l) = rainsub(k,l) end do @@ -256,7 +247,7 @@ subroutine clicon daylbsb = dayl(k) npcpbsb = npcp(k) u10bsb = u10(k) - do ii = 1, 24 + do ii = 1, nstep fradbsb(ii) = frad(k,ii) end do end if @@ -274,11 +265,6 @@ subroutine clicon & (1. + rfinc(hru_sub(k),i_mo) / 100.) if (rainsub(k,ii) < 0.) rainsub(k,ii) = 0. end do - do ii = 1, 24 - hhsubp(k,ii) = hhsubp(k,ii) * & - & (1. + rfinc(hru_sub(k),i_mo) / 100.) - if (hhsubp(k,ii) < 0.) hhsubp(k,ii) = 0. - end do end if tmx(k) = tmx(k) + tmpinc(hru_sub(k),i_mo) tmn(k) = tmn(k) + tmpinc(hru_sub(k),i_mo) @@ -349,12 +335,6 @@ subroutine clicon if (rainsub(k,ii) < 0.) rainsub(k,ii) = 0. end if end do - do ii = 1, 24 - if (hhsubp(k,ii) > 0.01) then - hhsubp(k,ii) = hhsubp(k,ii) + ratio * hhsubp(k,ii) - if (hhsubp(k,ii) < 0.) hhsubp(k,ii) = 0. - end if - end do end if end if end do diff --git a/src/command.f b/src/command.f index 62f5c0b..20aa171 100644 --- a/src/command.f +++ b/src/command.f @@ -121,6 +121,9 @@ subroutine command rnum1 = rnum1s(idum) inum4 = inum4s(idum) inum5 = inum5s(idum) + inum6 = inum6s(idum) + inum7 = inum7s(idum) + inum8 = inum8s(idum) select case (icode) case (0) @@ -169,9 +172,12 @@ subroutine command call saveconc case (17) call routeunit + call sumhyd case (18) - iru_sub = inunm1 !!routing unit number - call routels(iru_sub) + iru_sub = inum1 !!routing unit number + inum8 = 1 + call routels(iru_sub) + call sumhyd end select end do diff --git a/src/conapply.f b/src/conapply.f index 7c4a56e..c3fd1cd 100644 --- a/src/conapply.f +++ b/src/conapply.f @@ -22,8 +22,6 @@ subroutine conapply !! |the watershed !! laiday(:) |none |leaf area index !! nope(:) |none |sequence number of pesticide in NPNO(:) -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! nro(:) |none |sequence number of year in rotation !! nyskip |none |number of years to skip output !! |summarization/printing @@ -39,8 +37,6 @@ subroutine conapply !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! drift(:) |kg |amount of pesticide drifting onto main !! |channel in subbasin -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! plt_pst(:,:)|kg/ha |pesticide on plant foliage !! sol_pst(:,:,1)|kg/ha |pesticide in first layer of soil !! wshd_pstap(:)|kg/ha |total amount of pesticide type applied in diff --git a/src/confert.f b/src/confert.f index 0e55e1b..3cd02ec 100644 --- a/src/confert.f +++ b/src/confert.f @@ -169,7 +169,7 @@ subroutine confert it = cfrt_id(j) if (cfrt_kg(j) > 0.) then l = 1 - + if (cswat == 0 .or. cswat == 1) then sol_no3(l,j) = sol_no3(l,j) + cfrt_kg(j) * & & (1. - fnh3n(it)) * fminn(it) sol_fon(l,j) = sol_fon(l,j) + cfrt_kg(j) * & @@ -180,6 +180,54 @@ subroutine confert & fminp(it) sol_fop(l,j) = sol_fop(l,j) + cfrt_kg(j) * & & forgp(it) + end if + + !!Add by zhang + !!======================== + if (cswat == 2) then + sol_fop(l,j) = sol_fop(l,j) + cfrt_kg(j) * + & forgp(it) + sol_no3(l,j) = sol_no3(l,j) + cfrt_kg(j) * + & (1. - fnh3n(it)) * fminn(it) + sol_nh3(l,j) = sol_nh3(l,j) + cfrt_kg(j) * + & fnh3n(it) * fminn(it) + sol_solp(l,j) = sol_solp(l,j) + cfrt_kg(j) * + & fminp(it) + + orgc_f = 0.35 + !X1 fertilizer attributed to fresh carbon & nitrogen pool + X1 = cfrt_kg(j) + X8 = X1 * orgc_f + RLN = .175 *(orgc_f)/(fminn(it) + forgn(it) + 1.e-5) + X10 = .85-.018*RLN + if (X10<0.01) then + X10 = 0.01 + else + if (X10 > .7) then + X10 = .7 + end if + end if + XXX = X8 * X10 + sol_LMC(l,j) = sol_LMC(l,j) + XXX + YY = X1 * X10 + sol_LM(l,j) = sol_LM(l,j) + YY + ZZ = X1 *forgn(ifrt) * X10 + sol_LMN(l,j) = sol_LMN(l,j) + ZZ + sol_LSN(l,j) = sol_LSN(l,j) + X1 + & *forgn(it) -ZZ + XZ = X1 *orgc_f-XXX + sol_LSC(l,j) = sol_LSC(l,j) + XZ + sol_LSLC(l,j) = sol_LSLC(l,j) + XZ * .175 + sol_LSLNC(l,j) = sol_LSLNC(l,j) + XZ * (1.-.175) + YZ = X1 - YY + sol_LS(l,j) = sol_LS(l,j) + YZ + sol_LSL(l,j) = sol_LSL(l,j) + YZ*.175 + + sol_fon(l,j) = sol_LMN(l,j) + sol_LSN(l,j) + + end if + !!Add by zhang + !!======================== !! add bacteria - (cells/t*t/ha + 10t/m^3*mm*cells/t)/(t/ha + 10t/m^3*mm) !! calculate ground cover diff --git a/src/crackflow.f b/src/crackflow.f index 6a7fad8..2923b68 100644 --- a/src/crackflow.f +++ b/src/crackflow.f @@ -52,7 +52,7 @@ subroutine crackflow surfq(j) = 0. endif - if (ievent == 3) then + if (ievent >= 2) then voli = 0. voli = voltot do ii = 1, nstep !j.jeong 4/24/2009 diff --git a/src/dailycn.f b/src/dailycn.f index 5246d9e..46a3f5d 100644 --- a/src/dailycn.f +++ b/src/dailycn.f @@ -73,19 +73,12 @@ subroutine dailycn if (icn <= 0) then !! traditional CN method (function of soil water) if ((sol_sw(j) + Exp(xx)) > 0.001) then - r2 = smx(j) * (1. - sol_sw(j) / ( sol_sw(j) + Exp(xx))) + r2 = r2adj * smx(j) * (1. - sol_sw(j) / (sol_sw(j) + Exp(xx))) end if - else if (icn == 1) then !Daniel 1\2012 + else !! alternative CN method (function of plant ET) - r2 = amax1(3., sci(j)) - else - !Daniel 1/2012 - !! alternative CN method (Modified function of soil water for mildly-sloped tile-drained watersheds)!Daniel M 1/2012 - if ((sol_sw(j) + Exp(xx)) > 0.001) then - r2 = 8.0*smx(j) * (1. - sol_sw(j) / ( sol_sw(j) + Exp(xx))) - end if - !Daniel 1/2012 - end if + r2 = amax1(3., sci(j)) + end if if (sol_tmp(2,j) <= 0.) r2 = smx(j) * (1. - Exp(- cn_froz * r2)) r2 = amax1(3.,r2) diff --git a/src/depstor.f b/src/depstor.f index 93acdb2..5e92872 100644 --- a/src/depstor.f +++ b/src/depstor.f @@ -70,8 +70,13 @@ subroutine depstor !! Calculate the decay factor df based on %clay and %organic matter or %organic carbon ! sol_orgm = (sol_rsd(1,j)*0.01)/(sol_z(1,j)*sol_bd(1,j)) sol_orgm = sol_cbn(1,j)/0.58 - df = exp(0.943 - 0.07 * sol_clay(1,j) + 0.0011 * sol_clay(1,j)**2 & + xx = (0.943 - 0.07 * sol_clay(1,j) + 0.0011 * sol_clay(1,j)**2 & & - 0.67 * sol_orgm + 0.12 * sol_orgm**2) + if (xx > 1.) then + df = 1. + else + df = exp (xx) + end if !! Determine the current random and oriented roughness using cumei and cumrt and initial diff --git a/src/dormant.f b/src/dormant.f index 5efe354..09dab1f 100644 --- a/src/dormant.f +++ b/src/dormant.f @@ -88,6 +88,31 @@ subroutine dormant real :: resnew integer :: j + !!by zhang + !!==================== + + real :: BLG1, BLG2, BLG3, CLG, sf + real :: sol_min_n, resnew_n, resnew_ne + real :: LMF, LSF, LSLF, LSNF,LMNF + orgc_f = 0. + BLG1 = 0. + BLG2 = 0. + BLG3 = 0. + CLG = 0. + sf = 0. + sol_min_n = 0. + resnew = 0. + resnew_n = 0. + resnew_ne = 0. + LMF = 0. + LSF = 0. + LSLF = 0. + LSNF = 0. + LMNF = 0. + + !!by zhang + !!==================== + j = 0 j = ihru @@ -109,7 +134,118 @@ subroutine dormant case (7) idorm(j) = 1 resnew = 0. - resnew = bio_ms(j) * bio_leaf(idplt(j)) + resnew = bio_ms(j) * bio_leaf(idplt(j)) + + !!add by zhang + !!=================== + if (cswat == 2) then + rsdc_d(j) = rsdc_d(j) + resnew*0.42 + end if + !!add by zhang + !!=================== + + !!insert new biomss by zhang + !!============================= + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+ + & EXP(BLG1-BLG2*phuacc(j))) + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = bio_ms(j) * bio_leaf(idplt(j)) + resnew_n = resnew * pltfr_n(j) + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + !here a simplified assumption of 0.5 LSL + LSLF = 0.0 + LSLF = CLG + + sol_LSL(1,j) = sol_LSL(1,j) + RLR* LSF * resnew + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*LSF * resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=========================== + + sol_rsd(1,j) = sol_rsd(1,j) + resnew sol_rsd(1,j) = Max(sol_rsd(1,j),0.) sol_fon(1,j) = resnew * pltfr_n(j) + sol_fon(1,j) @@ -130,6 +266,119 @@ subroutine dormant idorm(j) = 1 resnew = 0. resnew = bm_dieoff(idplt(j)) * bio_ms(j) + + !!add by zhang + !!=================== + if (cswat == 2) then + rsdc_d(j) = rsdc_d(j) + resnew*0.42 + end if + !!add by zhang + !!=================== + + !!insert new biomss by zhang + !!============================= + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+ + & EXP(BLG1-BLG2*phuacc(j))) + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = bm_dieoff(idplt(j)) * bio_ms(j) + resnew_n = bm_dieoff(idplt(j)) * plantn(j) + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + !LSLF = 0.0 + !LSLF = CLG + + sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=========================== + + sol_rsd(1,j) = sol_rsd(1,j) + resnew sol_rsd(1,j) = Max(sol_rsd(1,j),0.) sol_fon(1,j) = sol_fon(1,j) + & diff --git a/src/drains.f b/src/drains.f index 88eaff6..a52fa34 100644 --- a/src/drains.f +++ b/src/drains.f @@ -7,27 +7,28 @@ subroutine drains !! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! conk(:,:) |mm/hr |lateral saturated hydraulic conductivity for each profile +!! conk(:,:) |mm/hr |lateral saturated hydraulic conductivity for each profile !! |layer in a give HRU. For example (conk(2,1) is conductivity !! |of layer from sol_z(1,1) to sol_z(2,1) in HRU1 !! curyr |none |current year in simulation (sequence) -!! drain_co(:) |mm/day |drainage coefficient -!! dg(:,:) |mm |depth of soil layer -!! ddrain(:) |mm |depth of drain tube from the soil surface -!! hru_slp(:) |m/m |average slope steepness in HRU +!! drain_co(:) |mm/day |drainage coefficient +!! dg(:,:) |mm |depth of soil layer +!! ddrain(:) |mm |depth of drain tube from the soil surface +!! hru_slp(:) |m/m |average slope steepness in HRU !! id1 |julian date |first day of simulation in current year !! ihru |none |HRU number -!! latksatf(:) |none |multiplication factor to determine conk(j1,j) from sol_k(j1,j) for HRU -!! pc(:) |mm/hr |pump capacity (default pump capacity = 1.042mm/hr or 25mm/day) -!! sdrain(:) |mm |distance between two drain tubes or tiles +!! latksatf(:) |none |multiplication factor to determine conk(j1,j) from sol_k(j1,j) for HRU +!! pc(:) |mm/hr |pump capacity (default pump capacity = 1.042mm/hr or 25mm/day) +!! sdrain(:) |mm |distance between two drain tubes or tiles +!! sstmaxd(:) |mm |static maximum depressional storage; read from .sdr !! sol_k(:,:) |mm/hr |saturated hydraulic conductivity of soil !! |layer !! sol_nly(:) |none |number of layers in soil profile -!! sol_z(:,:) |mm |depth to bottom of each profile layer in a given HRU -!! stmaxd(:) |mm |maximum surface depressional storage for the day in a given HRU -!! stor |mm |surface storage for the day in a given HRU -!! storro |mm |surface storage that must be filled before surface water -!! |can move to the tile drain tube +!! sol_z(:,:) |mm |depth to bottom of each profile layer in a given HRU +!! stmaxd(:) |mm |maximum surface depressional storage for the day in a given HRU +!! stor |mm |surface storage for the day in a given HRU +!! storro |mm |surface storage that must b +!! |can move to the tile drain tube !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ @@ -41,31 +42,31 @@ subroutine drains !! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! above |mm |depth of top layer considered -!! adepth |mm |actual depth from surface to impermeable layer -!! cone |mm/hr |effective saturated lateral conductivity - based +!! above |mm |depth of top layer considered +!! depth |mm |actual depth from surface to impermeable layer +!! cone |mm/hr |effective saturated lateral conductivity - based !! |on water table depth and conk/sol_k of layers -!! ddarnp |mm |a variable used to indicate distance slightly less +!! ddarnp |mm |a variable used to indicate distance slightly less !! |than ddrain. Used to prevent calculating subirrigation !! |when water table is below drain bottom or when it is empty -!! deep |mm |total thickness of saturated zone -!! depth |mm |effective depth to impermeable layer from soil surface -!! |effective depth may be smaller than actual depth to account -!! |for convergence near drain tubes -!! dflux |mm/hr |drainage flux -!! dot |mm |actual depth from impermeable layer to water level -!! |above drain during subsurface irrigation -!! em |mm |distance from water level in the drains to water table +!! deep |mm |total thickness of saturated zone +!! depth |mm |effective depth to impermeable layer from soil surface +!! |effective depth may be smaller than actual depth to account +!! |for convergence near drain tubes +!! dflux |mm/hr |drainage flux +!! dot |mm |actual depth from impermeable layer to water level +!! |above drain during subsurface irrigation +!! em |mm |distance from water level in the drains to water table !! |at midpoint: em is negative during subirrigation -!! gee |none |factor -g- in Kirkham equation -!! hdrain |mm |equivalent depth from water surface in drain tube to -!! |impermeable layer +!! gee |none |factor -g- in Kirkham equation +!! hdrain |mm |equivalent depth from water surface in drain tube to +!! |impermeable layer !! i |none |counter !! j |none |HRU number -!! j1 |none |counter -!! w |mm |thickness of saturated zone in layer considered +!! j1 |none |counter +!! w |mm |thickness of saturated zone in layer considered !! y1 |mm |dummy variable for dtwt -!! nlayer |none |number of layers to be used to determine cone +!! nlayer |none |number of layers to be used to determine cone !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ @@ -77,28 +78,28 @@ subroutine drains use parm integer :: j1, j, m - real:: cone, depth, dg, ad, ap - real:: hdrain, gee, e, gee1, gee2, gee3, pi + real:: cone, depth, dg, ad, ap + real:: hdrain, gee, e, gee1, gee2, gee3, pi real:: k2, k3, k4, k5, k6 !! initialize variables j = 0 j = ihru - wnan = 0 + wnan = 0 y1 = dep_imp(j) - wt_shall - if (y1 > dep_imp(j)) y1 = dep_imp(j) - above = 0. - pi = 22./7. - gee1 =0. + if (y1 > dep_imp(j)) y1 = dep_imp(j) + above = 0. + pi = 22./7. + gee1 =0. !! find number of soil layers do j1 = 1, mlyr if(sol_z(j1,j) > 0.) nlayer = j1 - end do + end do !! find effective lateral hydraulic conductivity for the profile in hru j - do j1 = 1, nlayer + do j1 = 1, nlayer if(y1 > sol_z(j1,j)) then wnan(j1) = 0. else @@ -109,13 +110,13 @@ subroutine drains above = sol_z(j1,j) end do sum = 0. - deep = 0. - do j1=1,nlayer - conk(j1,j) = sol_k(j1,j) * latksatf(j) !Daniel 2/26/09 - sum = sum + wnan(j1) * conk(j1,j) - deep = deep + wnan(j1) + deep = 0. + do j1=1,nlayer + conk(j1,j) = sol_k(j1,j) * latksatf(j) !Daniel 2/26/09 + sum = sum + wnan(j1) * conk(j1,j) + deep = deep + wnan(j1) end do - if((deep <= 0.001).or.(sum <= 0.001)) then + if((deep <= 0.001).or.(sum <= 0.001)) then sum = 0. deep = 0.001 do j1=1,nlayer @@ -133,78 +134,89 @@ subroutine drains cone=sum/deep else cone=sum/deep - end if + end if !! calculate parameters hdrain and gee1 ad = dep_imp(j) - ddrain(j) ap = 3.55 - ((1.6 * ad) / sdrain(j)) + 2 * ((2 / sdrain(j))**2) if (ad/sdrain(j) < 0.3) then - hdrain= ad / (1 + ((ad / sdrain(j)) * (((8 / pi) * - & Log(ad / re(j)) - ap)))) + hdrain= ad / (1 + ((ad / sdrain(j)) * (((8 / pi) * + & Log(ad / re(j)) - ap)))) else - hdrain = (sdrain(j) * pi) / (8 * ((log(sdrain(j) / re(j))/ + hdrain = (sdrain(j) * pi) / (8 * ((log(sdrain(j) / re(j))/ & log(e)) - 1.15)) end if - !! calculate Kirkham G-Factor, gee - k2 = tan((pi * ((2. * ad) - re(j))) / (4. * dep_imp(j))) - k3 = tan((pi * re(j)) / (4. * dep_imp(j))) + !! calculate Kirkham G-Factor, gee + k2 = tan((pi * ((2. * ad) - re(j))) / (4. * dep_imp(j))) + k3 = tan((pi * re(j)) / (4. * dep_imp(j))) do m=1,2 - k4 = (pi * m * sdrain(j)) / (2 * dep_imp(j)) - k5 = (pi * re(j)) / (2 * dep_imp(j)) - k6 = (pi * (2 * ad-re(j))) / (2 * dep_imp(j)) - gee2 = (cosh(k4) + cos(k5)) / (cosh(k4) - cos(k5)) - gee3 = (cosh(k4) - cos(k6)) / (cosh(k4) + cos(k6)) - gee1 = gee1 + Log(gee2 * gee3) + k4 = (pi * m * sdrain(j)) / (2. * dep_imp(j)) + k5 = (pi * re(j)) / (2. * dep_imp(j)) + k6 = (pi * (2. * ad - re(j))) / (2. * dep_imp(j)) + gee2 = (cosh(k4) + cos(k5)) / (cosh(k4) - cos(k5)) + gee3 = (cosh(k4) - cos(k6)) / (cosh(k4) + cos(k6)) + gee1 = gee1 + Log(gee2 * gee3) end do - gee = 2 * Log(k2 / k3) + 2 * gee1 + xx = k2 / k3 + if (xx < 1.) then + gee = 1. + else + gee = 2 * Log(k2 / k3) + 2 * gee1 + end if + if (gee < 1.) gee = 1. + if (gee > 12.) gee = 12. - !! calculate drainage and subirrigation flux section + !! calculate drainage and subirrigation flux section ! drainage flux for ponded surface depth = ddrain(j) + hdrain - hdmin = depth - ddrain(j) - call depstor ! dynamic stmaxd(j): compute current HRU stmaxd based - ! on cumulative rainfall and cum. intensity - storro = 0.2 * stmaxd(j) !surface storage that must be filled before surface - !water can move to the tile drain tube + hdmin = depth - ddrain(j) + if (ismax == 1) then + call depstor ! dynamic stmaxd(j): compute current HRU stmaxd based + ! on cumulative rainfall and cum. intensity + else + stmaxd(j) = sstmaxd(j) + end if + storro = 0.2 * stmaxd(j) !surface storage that must be filled before surface + !water can move to the tile drain tube !! Determine surface storage for the day in a given HRU (stor) - !initialize stor on the beginning day of simulation, Daniel 9/20/2007 - if(curyr == 1 .and. iida == id1) then + !initialize stor on the beginning day of simulation, Daniel 9/20/2007 + if (curyr == 1 .and. iida == id1) then stor= 0. end if if (potsa(j) <= 0.) then ! determine stor stor = precipday - inflpcp - etday !Daniel 10/05/07 if(surfq(j) > 0.0) stor=stmaxd(j) - else + else stor = pot_vol(j)/(potsa(j)*1000) - endif - if(hdrain < hdmin) hdrain=hdmin - if((stor > storro).and.(y1 < 5.0)) then - dflux= (12.56637*24.0*cone*(depth-hdrain+stor))/ - & (gee*sdrain(j)) !eq.10 - if(dflux > drain_co(j)) dflux = drain_co(j) !eq.11 - else + endif + if(hdrain < hdmin) hdrain=hdmin + if((stor > storro).and.(y1 < 5.0)) then + dflux= (12.56637*24.0*cone*(depth-hdrain+stor))/ + & (gee*sdrain(j)) !eq.10 + if(dflux > drain_co(j)) dflux = drain_co(j) !eq.11 + else ! subirrigation flux - em=depth-y1-hdrain - if(em < -1.0) then - ddranp=ddrain(j)-1.0 - dot=hdrain+dep_imp(j)-depth - dflux=4.0*24.0*cone*em*hdrain*(2.0+em/dot)/sdrain(j)**2 - if((depth-hdrain) >= ddranp) dflux=0. - if(abs(dflux) > pc(j)) then - dflux = -pc(j)*24.0 - end if + em=depth-y1-hdrain + if(em < -1.0) then + ddranp=ddrain(j)-1.0 + dot=hdrain+dep_imp(j)-depth + dflux=4.0*24.0*cone*em*hdrain*(2.0+em/dot)/sdrain(j)**2 + if((depth-hdrain) >= ddranp) dflux=0. + if(abs(dflux) > pc(j)) then + dflux = -pc(j)*24.0 + end if ! drainage flux - for WT below the surface and for ponded depths < storro (S1) - else - dflux=4.0*24.0*cone*em*(2.0*hdrain+em)/sdrain(j)**2 !eq.5 - if(dflux > drain_co(j)) dflux=drain_co(j) !eq.11 - if(dflux < 0.) dflux=0. - if(em < 0.) dflux=0. - end if + else + dflux=4.0*24.0*cone*em*(2.0*hdrain+em)/sdrain(j)**2 !eq.5 + if(dflux > drain_co(j)) dflux=drain_co(j) !eq.11 + if(dflux < 0.) dflux=0. + if(em < 0.) dflux=0. + end if end if qtile=dflux -! write(222,222) curyr, iida, hdrain, gee1, gee !Daniel 3/1/09 -222 format(1x,4x,i4,4x,i3,4x,3f12.3) - return - end +! write(222,222) curyr, iida, hdrain, gee1, gee !Daniel 3/1/09 +!222 format(1x,4x,i4,4x,i3,4x,3f12.3) + return + end diff --git a/src/eiusle.f b/src/eiusle.f index a99295d..8b0cf1a 100644 --- a/src/eiusle.f +++ b/src/eiusle.f @@ -72,6 +72,7 @@ subroutine eiusle & pkrf30 / 1000. ! * peakr / 10. if (usle_ei < 1.e-4) usle_ei = 0. + usle_eifac(j) = usle_ei endif return diff --git a/src/etact.f b/src/etact.f index ba08b96..7b02f09 100644 --- a/src/etact.f +++ b/src/etact.f @@ -167,7 +167,7 @@ subroutine etact eos1 = es_max * eos1 es_max = Min(es_max, eos1) es_max = Max(es_max, 0.) - if (pot_vol(j) > 1.e-4) es_max = 0. +! if (pot_vol(j) > 1.e-4) es_max = 0. !! make sure maximum plant and soil ET doesn't exceed potential ET if (pet_day < es_max + ep_max) then diff --git a/src/fert.f b/src/fert.f index c026e54..dea21d2 100644 --- a/src/fert.f +++ b/src/fert.f @@ -150,6 +150,22 @@ subroutine fert integer :: j, l, ifrt real :: xx, gc, gc1, swf, frt_t + !!added by zhang + !!====================== + real :: X1, X8, X10, XXX, YY, ZZ, XZ, YZ, RLN, orgc_f + X1 = 0. + X8 = 0. + X10 = 0. + XXX = 0. + YY = 0. + ZZ = 0. + XZ = 0. + YZ = 0. + RLN = 0. + orgc_f = 0. + !!added by zhang + !!====================== + j = 0 j = ihru @@ -176,7 +192,8 @@ subroutine fert & frt_kg * forgp(ifrt) sol_orgp(l,j) = sol_orgp(l,j) + (1. - rtof) * xx * & & frt_kg * forgp(ifrt) - else + end if + if (cswat == 1) then sol_mc(l,j) = sol_mc(l,j) + xx * frt_kg * & forgn(ifrt) * 10. sol_mn(l,j) = sol_mn(l,j) + xx * frt_kg * @@ -185,6 +202,89 @@ subroutine fert & forgp(ifrt) end if + !!By Zhang for C/N cycling + !!=========================== + if (cswat == 2) then + !sol_fon(l,j) = sol_fon(l,j) + rtof * xx * & + & ! frt_kg(nro(j),nfert(j),j) * forgn(ifrt) + !sol_aorgn(l,j) = sol_aorgn(l,j) + (1. - rtof) * xx * + & ! frt_kg(nro(j),nfert(j),j) * forgn(ifrt) + sol_fop(l,j) = sol_fop(l,j) + rtof * xx * + & frt_kg * forgp(ifrt) + sol_orgp(l,j) = sol_orgp(l,j) + (1. - rtof) * xx * + & frt_kg * forgp(ifrt) + + !!Allocate organic fertilizer to Slow (SWAT_active) N pool; + sol_HSN(l,j) = sol_HSN(l,j) + (1. - rtof) * xx * + & frt_kg * forgn(ifrt) + sol_aorgn(l,j) = sol_HSN(l,j) + + + + !orgc_f is the fraction of organic carbon in fertilizer + !for most fertilziers this value is set to 0. + orgc_f = 0.0 + !X1 is fertlizer applied to layer (kg/ha) + !xx is fraction of fertilizer applied to layer + X1 = xx * frt_kg + !X8: organic carbon applied (kg C/ha) + X8 = X1 * orgc_f + !RLN is calculated as a function of C:N ration in fertilizer + RLN = .175 *(orgc_f)/(fminn(ifrt) + forgn(ifrt) + 1.e-5) + + !X10 is the fraction of carbon in fertilizer that is allocated to metabolic litter C pool + X10 = .85-.018*RLN + if (X10<0.01) then + X10 = 0.01 + else + if (X10 > .7) then + X10 = .7 + end if + end if + + !XXX is the amount of organic carbon allocated to metabolic litter C pool + XXX = X8 * X10 + sol_LMC(l,j) = sol_LMC(l,j) + XXX + !YY is the amount of fertilizer (including C and N) allocated into metabolic litter SOM pool + YY = X1 * X10 + sol_LM(l,j) = sol_LM(l,j) + YY + + !ZZ is amount of organic N allocated to metabolic litter N pool + ZZ = X1 *rtof *forgn(ifrt) * X10 + + + sol_LMN(l,j) = sol_LMN(l,j) + ZZ + + !!remaining organic N is llocated to structural litter N pool + sol_LSN(l,j) = sol_LSN(l,j) + X1 + & *forgn(ifrt) -ZZ + !XZ is the amount of organic carbon allocated to structural litter C pool + XZ = X1 *orgc_f-XXX + sol_LSC(l,j) = sol_LSC(l,j) + XZ + + !assuming lignin C fraction of organic carbon to be 0.175; updating lignin amount in strucutral litter pool + sol_LSLC(l,j) = sol_LSLC(l,j) + XZ * .175 + !non-lignin part of the structural litter C is also updated; + sol_LSLNC(l,j) = sol_LSLNC(l,j) + XZ * (1.-.175) + + !YZ is the amount of fertilizer (including C and N) allocated into strucutre litter SOM pool + YZ = X1 - YY + sol_LS(l,j) = sol_LS(l,j) + YZ + !assuming lignin fraction of the organic fertilizer allocated into structure litter SOM pool to be 0.175; + !update lignin weight in structural litter. + sol_LSL(l,j) = sol_LSL(l,j) + YZ*.175 + + + + + sol_fon(l,j) = sol_LMN(l,j) + sol_LSN(l,j) + + !end if + + end if + !!By Zhang for C/N cycling + !!=========================== + sol_nh3(l,j) = sol_nh3(l,j) + xx * frt_kg * & & fnh3n(ifrt) * fminn(ifrt) diff --git a/src/getallo.f b/src/getallo.f index 999ab7b..603ea42 100644 --- a/src/getallo.f +++ b/src/getallo.f @@ -239,7 +239,8 @@ subroutine getallo inm3 = 0 mhru = 0 mch = 1 - msub = 1 + mru = 1 + msub = 0 mhyd = 1 mres = 0 mlyr = 0 @@ -258,7 +259,6 @@ subroutine getallo mtran = 0 nsave = 0 nlsu = 0 - !! nauto = 0 !! calculate number of records in plant growth database eof = 0 @@ -358,11 +358,12 @@ subroutine getallo end do if (mtil <= 0) mtil = 1 close (30) - + !! process .fig file allocate (pstflg(mpdb)) pstflg = 0 + mhru1 = 1 open (27,file=figfile) do while (icd > 0) read (27,5002) a @@ -385,7 +386,11 @@ subroutine getallo end do read (25,*) numhru mhru = mhru + numhru - call hruallo(numhru) + do j = 1, 8 + read (25,6000) titldum + end do + call hruallo + mhru1 = mhru + 1 close (25) case (2) !! icd = 2 ROUTE command mch = mch + 1 !! # channels @@ -399,37 +404,47 @@ subroutine getallo case (6) !! icd = 6 RECALL HOUR command read (27,5002) a mrech = mrech + 1 + mrech = MAX(mrech,inm1) case (7) !! icd = 7 RECALL MONTH command read (27,5002) a mrecm = mrecm + 1 + mrecm = MAX(mrecm,inm1) case (8) !! icd = 8 RECALL YEAR command read (27,5002) a mrecy = mrecy + 1 + mrecy = MAX(mrecy,inm1) case (9) !! icd = 9 SAVE command read (27,5002) a nsave = nsave + 1 case (10) !! icd = 10 RECALL DAY command read (27,5002) a mrecd = mrecd + 1 + mrecd = MAX(mrecd,inm1) case (11) !! icd = 11 RECALL CONSTANT command read (27,5002) a mrecc = mrecc + 1 + mrecc = MAX(mrecc,inm1) case (13) !! icd = 13 APEX command read (27,5002) a mapex = mapex + 1 + mapex = MAX(mapex,inm1) case (14) !! icd = 14 SAVECONC command read (27,5002) a nsave = nsave + 1 case (17) !! icd = 17 ROUTING UNIT command read (27,5002) a - rutot = rutot + 1 + mru = mru + 1 end select mhyd = Max(mhyd,iht) end if - end do + end do close (27) + + if (ils_nofig == 1) then + mru = Max(mru,2*msub) + end if if (mhru <= 0) mhru = 1 if (msub <= 0) msub = 1 if (mch <= 0) mch = 1 @@ -440,11 +455,14 @@ subroutine getallo if (mrecy <= 0) mrecy = 1 if (mres <= 0) mres = 1 - !! mhyd = mhyd + nsave + nauto + mtran + 1 mhyd = mhyd + nsave + mtran + 1 -!! septic change 1-28-09 gsm + if (ils_nofig == 1) then + mhyd = mhyd + 6 * msub + end if + +!! septic change 1-28-09 gsm mlyr = mlyr + 4 -!! septic change 1-28-09 gsm +!! septic change 1-28-09 gsm mcr = mcr + 1 mcr = Max(2,mcr) diff --git a/src/getallo2.f b/src/getallo2.f deleted file mode 100644 index ca88f4e..0000000 --- a/src/getallo2.f +++ /dev/null @@ -1,435 +0,0 @@ - subroutine getallo2 - -!! ~ ~ ~ PURPOSE ~ ~ ~ -!! This subroutine calculates the number of HRUs, subbasins, etc. in the -!! simulation. These values are used to allocate array sizes. - -!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ -!! name |units |definition -!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! mapp |none |maximum number of applications -!! mch |none |maximum number of channels -!! mcr |none |maximum number of crops grown per year -!! mcrdb |none |max number of lu/lc defined in crop.dat -!! mcut |none |maximum number of cuttings per year -!! mfdb |none |max number of fertilizers in fert.dat -!! mgr |none |maximum number of grazings per year -!! mhru |none |maximum number of HRUs in watershed -!! mhyd |none |maximum number of hydrograph nodes -!! mlyr |none |maximum number of soil layers -!! mnr |none |max number of years of rotation -!! mpst |none |max number of pesticides used in wshed -!! mpdb |none |max number of pesticides in pest.dat -!! mrecc |none |maximum number of reccnst files -!! mrecd |none |maximum number of recday files -!! mrech |none |maximum number of rechour files -!! mrecm |none |maximum number of recmon files -!! mrecy |none |maximum number of recyear files -!! mres |none |maximum number of reservoirs -!! mrg |none |max number of rainfall/temp gages -!! nstep |none |max number of time steps per day -!! msub |none |maximum number of subbasins -!! mtil |none |max number of tillage types in till.dat -!! mudb |none |maximum number of urban land types in urban.dat -!! myr |none |max number of years of simulation -!! pstflg(:) |none |flag for types of pesticide used in watershed -!! |array location is pesticide ID number -!! |0: pesticide not used -!! |1: pesticide used -!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - -!! ~ ~ ~ LOCAL VARIABLES ~ ~ ~ -!! name |units |definition -!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! a |NA |comment flag -!! plantdb |NA |name of LU/LC database input file (crop.dat) -!! eof |none |end of file flag -!! fertdb |NA |name of fertilizer database file (fert.dat) -!! figfile |NA |name of watershed configuration file (.fig) -!! i |none |counter -!! ic |none |number of land cover in crop database -!! icd |none |routing command code (.fig) -!! ifnum |none |number of fertilizer type in database file -!! iht |none |hydrograph storage location number (.fig) -!! inm1 |none |1st routing command variable (.fig) -!! inm2 |none |2nd routing command variable (.fig) -!! inm3 |none |3rd routing command variable (.fig) -!! |if icd=1, inm3=subbasin # -!! ipnum |none |number of pesticide type in database file -!! itnum |none |number of tillage implement in database file -!! iunum |none |number of urban land type in database file -!! j |none |counter -!! nhtot |none |number of relative humidity records in file -!! nrgage |none |number of raingage files -!! nrgfil |none |number of rain gages per file -!! nrtot |none |total number of rain gages -!! nsave |none |number of save commands in .fig file -!! nstot |none |number of solar radiation records in file -!! ntgage |none |number of temperature gage files -!! ntgfil |none |number of temperature gages per file -!! nttot |none |total number of temperature gages -!! numhru |none |number of HRUs listed in subbasin file -!! nwtot |none |number of wind speed records in file -!! pestdb |NA |name of pesticide database input file(pest.dat) -!! subfile |NA |name of subbasin input file (.sub) -!! tilldb |NA |name of tillage database input file(till.dat) -!! title |NA |description lines in file.cio(1st 3 lines) -!! titldum |NA |variable to read in data line -!! urbandb |NA |name of urban land type database file -!! |(urban.dat) -!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - -!! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ -!! Intrinsic: Max -!! SWAT: caps - -!! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ - - - use parm - - - character (len=13) :: urbandb, plantdb, tilldb, pestdb, figfile, & - & fertdb, subfile, bsnfile - character (len=1) :: a - character (len=80) :: titldum - integer :: icd, inm1, inm2, inm3, iht, eof, numhru, ic - integer :: ipnum, ifnum, iunum, itnum, j - -!! initialize variables - title = "" - plantdb = "" - tilldb = "" - pestdb = "" - fertdb = "" - urbandb = "" - figfile = "" - bsnfile = "" - nrgage = 0 - ntgage = 0 - nrtot = 0 - nttot = 0 - nrgfil = 0 - ntgfil = 0 - nstot = 0 - nhtot = 0 - nwtot = 0 - nstep = 0 - myr = 0 - - open (23,file="file.cio") - read (23,6000) titldum - read (23,6000) titldum - read (23,5100) title - read (23,6000) titldum - read (23,5000) figfile - read (23,*) myr - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,*) nstep - read (23,6000) titldum - read (23,6000) titldum - read (23,*) nrgage - read (23,*) nrtot - read (23,*) nrgfil - read (23,6000) titldum - read (23,*) ntgage - read (23,*) nttot - read (23,*) ntgfil - read (23,6000) titldum - read (23,*) nstot - read (23,6000) titldum - read (23,*) nhtot - read (23,6000) titldum - read (23,*) nwtot - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,6000) titldum - read (23,5000) bsnfile - read (23,6000) titldum - read (23,5000) plantdb - read (23,5000) tilldb - read (23,5000) pestdb - read (23,5000) fertdb - read (23,5000) urbandb - -!! read title lines from septic database file - do nlines = 1, 24 - read (23,6000,iostat=eof) titldum - if (eof < 0) exit - end do - - read (23,5000,iostat=eof) septdb - -!! calculate max number of years simulated, daily time increment - myr = myr + 2 - if (nstep <= 0) then - nstep = 1 - else - nstep = 1440 / nstep - end if - nstep = nstep + 1 - - call caps(plantdb) - call caps(fertdb) - call caps(pestdb) - call caps(figfile) - call caps(tilldb) - call caps(urbandb) - -!! open .bsn file to get ievent input - open (103,file=bsnfile) - call caps(bsnfile) - do nlines = 1, 17 - read (103,6000,iostat=eof) titldum - if (eof < 0) exit - end do - read (103,*,iostat=eof) ievent - if (ievent == 1) nstep = 24 - - -!! open routing file - open (27,file=figfile) - -!! opens database files - open (29,file=plantdb) - open (30,file=tilldb) - open (31,file=pestdb) - open (7,file=fertdb) - open (8,file=urbandb) - -!! initialize variables - a = "" - icd = 1 - iht = 0 - inm1 = 0 - inm2 = 0 - inm3 = 0 - mhru = 0 - mch = 1 - msub = 1 - mhyd = 1 - mres = 0 - mlyr = 0 - mpst = 0 - mcr = 0 - mapp = 0 - mgr = 0 - mcut = 0 - mnr = 0 - mapex = 0 - mrecc = 0 - mrecd = 0 - mrech = 0 - mrecm = 0 - mrecy = 0 - mtran = 0 - nsave = 0 - !! nauto = 0 - - -!! calculate number of records in plant growth database - eof = 0 - mcrdb = 0 - do - ic = 0 - read (29,*,iostat=eof) ic - if (eof < 0) exit - read (29,6000,iostat=eof) titldum - if (eof < 0) exit - read (29,6000,iostat=eof) titldum - if (eof < 0) exit - read (29,6000,iostat=eof) titldum - if (eof < 0) exit - read (29,6000,iostat=eof) titldum - if (eof < 0) exit - mcrdb = Max(mcrdb,ic) - end do - if (mcrdb <= 0) mcrdb = 1 - -!! calculate number of records in urban database - eof = 0 - mudb = 0 - do - iunum = 0 - read (8,6200,iostat=eof) iunum - if (eof < 0) exit - read (8,6000,iostat=eof) titldum - if (eof < 0) exit - mudb = Max(mudb,iunum) - end do - if (mudb <= 0) mudb = 1 - -!! calculate number of records in fertilizer database - eof = 0 - mfdb = 0 - do - ifnum = 0 - read (7,6300,iostat=eof) ifnum - if (eof < 0) exit - mfdb = Max(mfdb,ifnum) - end do - if (mfdb <= 0) mfdb = 1 - -!! calculate number of records in pesticide database - eof = 0 - mpdb = 0 - do - ipnum = 0 - read (31,6200,iostat=eof) ipnum - if (eof < 0) exit - mpdb = Max(mpdb,ipnum) - end do - if (mpdb <= 0) mpdb = 1 - -!! calculate number of records in tillage database - eof = 0 - mtil = 0 - do - itnum = 0 - read (30,6300,iostat=eof) itnum - if (eof < 0) exit - mtil = Max(mtil,itnum) - end do - if (mtil <= 0) mtil = 1 - - -!! process .fig file - pstflg = 0 - do while (icd > 0) - read (27,5002) a - if (a /= "*") then - backspace 27 - - read (27,5001) a, icd, iht, inm1, inm2, inm3 - - select case (icd) - case (1) !! icd = 1 SUBBASIN command - msub = msub + 1 !! # subbasins - !! calculate total number of HRUs in watershed - subfile = "" - numhru = 0 - read (27,6100) subfile - call caps(subfile) - open (25,file=subfile) - do j = 1,52 - read (25,6000) titldum - end do - read (25,*) numhru - mhru = mhru + numhru - call hruallo(numhru) -!! routing add 5/24/2010 - read (25,6000,iostat=eof) titldum -!! if (eof >= 0) then - if (eof > 0) then - read (25,5002,iostat=eof) irt - if (irt == 1) then - call ruallo - end if - end if - close (25) - case (2) !! icd = 2 ROUTE command - mch = mch + 1 !! # channels - read (27,5002) a - case (3) !! icd = 3 ROUTE RESERVOIR command - mres = mres + 1 - read (27,5002) a - case (4) !! icd = 4 TRANSFER command - mtran = mtran + 1 - case (6) !! icd = 6 RECALL HOUR command - read (27,5002) a - mrech = mrech + 1 - case (7) !! icd = 7 RECALL MONTH command - read (27,5002) a - mrecm = mrecm + 1 - case (8) !! icd = 8 RECALL YEAR command - read (27,5002) a - mrecy = mrecy + 1 - case (9) !! icd = 9 SAVE command - read (27,5002) a - nsave = nsave + 1 - case (10) !! icd = 10 RECALL DAY command - read (27,5002) a - mrecd = mrecd + 1 - case (11) !! icd = 11 RECALL CONSTANT command - read (27,5002) a - mrecc = mrecc + 1 - case (13) !! icd = 13 APEX command - read (27,5002) a - mapex = mapex + 1 - case (14) !! icd = 14 SAVECONC command - read (27,5002) a - nsave = nsave + 1 - end select - - mhyd = Max(mhyd,iht) - - end if - end do - if (mhru <= 0) mhru = 1 - if (msub <= 0) msub = 1 - if (mch <= 0) mch = 1 - mch = Max(mch,msub+1) - if (mrecc <= 0) mrecc = 1 - if (mrecd <= 0) mrecd = 1 - if (mrech <= 0) mrech = 1 - if (mrecm <= 0) mrecm = 1 - if (mrecy <= 0) mrecy = 1 - if (mres <= 0) mres = 1 - - !! mhyd = mhyd + nsave + nauto + mtran + 1 - mhyd = mhyd + nsave + mtran + 1 -!! septic change 1-28-09 gsm - mlyr = mlyr + 4 -!! septic change 1-28-09 gsm - - mcr = mcr + 1 - mcr = Max(2,mcr) - mapp = mapp + 1 - mgr = mgr + 1 - mcut = mcut + 1 - mnr = mnr + 1 - mpst = Sum(pstflg) + 1 - -!! calculate max number of climate gages - mrg = 0 - mrg = Max(nrtot,nttot,nstot,nhtot,nwtot) - if (mrg <= 0) mrg = 1 - - close (23) - close (27) - close (29) - close (30) - close (31) - close (103) - close (7) - close (8) - return - 5000 format (6a) - 5001 format (a1,9x,5i6) - 5002 format(a) - 5100 format (20a4) -!$$$$$$ 5200 format (10i4) - 6000 format (a80) - 6100 format (10x,a13) - 6200 format (i3) - 6300 format (i4) - end - diff --git a/src/graze.f b/src/graze.f index b1dd712..83ef1dd 100644 --- a/src/graze.f +++ b/src/graze.f @@ -185,6 +185,14 @@ subroutine graze bio_ms(j) = bio_ms(j) - bio_eat(j) if (bio_ms(j) < bio_min(j)) bio_ms(j) = bio_min(j) + !!add by zhang + !!================= + if (cswat == 2) then + emitc_d(j) = emitc_d(j) + dmi - bio_ms(j) + end if + !!add by zhang + !!================= + !! adjust nutrient content of biomass plantn(j) = plantn(j) - (dmi - bio_ms(j)) * pltfr_n(j) plantp(j) = plantp(j) - (dmi - bio_ms(j)) * pltfr_p(j) @@ -198,12 +206,28 @@ subroutine graze if (bio_ms(j) < bio_min(j)) then sol_rsd(1,j) = sol_rsd(1,j) + dmii - bio_min(j) bio_ms(j) = bio_min(j) + !!add by zhang + !!================= + if (cswat == 2) then + rsdc_d(j) = rsdc_d(j) + dmii - bio_ms(j) + end if + !!add by zhang + !!================= else - sol_rsd(1,j) = sol_rsd(1,j) + bio_trmp(j) + sol_rsd(1,j) = sol_rsd(1,j) + bio_trmp(j) + !!add by zhang + !!================= + if (cswat == 2) then + rsdc_d(j) = rsdc_d(j) + bio_trmp(j) + end if + !!add by zhang + !!================= endif sol_rsd(1,j) = Max(sol_rsd(1,j),0.) bio_ms(j) = Max(bio_ms(j),0.) + + !! adjust nutrient content of residue and biomass for !! trampling plantn(j) = plantn(j) - (dmii - bio_ms(j)) * pltfr_n(j) @@ -212,6 +236,111 @@ subroutine graze if (plantp(j) < 0.) plantp(j) = 0. if (dmii - bio_ms(j) > 0.) then sol_fon(1,j) = (dmii - bio_ms(j)) * pltfr_n(j) + sol_fon(1,j) + + !!insert new biomss by zhang + !!=========================== + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XXX = log(0.5/BLG1-0.5) + BLG2 = (XXX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XXX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+ + & EXP(BLG1-BLG2*phuacc(j))) + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = (dmii - bio_ms(j)) + resnew_n = (dmii - bio_ms(j)) * pltfr_n(j) + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + !LSLF = 0.0 + !LSLF = CLG + + sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42* resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=========================== + + sol_fop(1,j) = (dmii - bio_ms(j)) * pltfr_p(j) + sol_fop(1,j) end if @@ -234,7 +363,8 @@ subroutine graze & fminp(it) sol_fop(l,j) = sol_fop(l,j) + manure_kg(j) * & & forgp(it) - else + end if + if (cswat == 1) then sol_no3(l,j) = sol_no3(l,j) + manure_kg(j) * & & (1. - fnh3n(it)) * fminn(it) sol_mn(l,j) = sol_mn(l,j) + manure_kg(j) * @@ -248,7 +378,57 @@ subroutine graze sol_mc(l,j) = sol_mc(l,j) + manure_kg(j) * & forgn(it) * 10. end if + + !!By Zhang for C/N cycling + !!=============================== + if (cswat == 2) then + sol_no3(l,j) = sol_no3(l,j) + manure_kg(j) * + & (1. - fnh3n(it)) * fminn(it) + !sol_fon(l,j) = sol_fon(l,j) + manure_kg(j) * + & ! forgn(it) + orgc_f = 0.35 + X1 = manure_kg(j) + X8 = X1 * orgc_f + RLN = .175 *(orgc_f)/(fminp(it) + forgn(it) + 1.e-5) + X10 = .85-.018*RLN + if (X10<0.01) then + X10 = 0.01 + else + if (X10 > .7) then + X10 = .7 + end if + end if + XX = X8 * X10 + sol_LMC(l,j) = sol_LMC(l,j) + XX + YY = manure_kg(j) * X10 + sol_LM(l,j) = sol_LM(l,j) + YY + ZZ = manure_kg(j) *forgn(it) * X10 + sol_LMN(l,j) = sol_LMN(l,j) + ZZ + sol_LSN(l,j) = sol_LSN(l,j) + manure_kg(j) + & *forgn(it) -ZZ + XZ = manure_kg(j) *orgc_f-XX + sol_LSC(l,j) = sol_LSC(l,j) + XZ + sol_LSLC(l,j) = sol_LSLC(l,j) + XZ * .175 + sol_LSLNC(l,j) = sol_LSLNC(l,j) + XZ * (1.-.175) + YZ = manure_kg(j) - YY + sol_LS(l,j) = sol_LS(l,j) + YZ + sol_LSL(l,j) = sol_LSL(l,j) + YZ*.175 + + + sol_fon(l,j) = sol_LMN(l,j) + sol_LSN(l,j) + + + sol_nh3(l,j) = sol_nh3(l,j) + manure_kg(j) * + & fnh3n(it) * fminn(it) + sol_solp(l,j) = sol_solp(l,j) + manure_kg(j) * + & fminp(it) + sol_fop(l,j) = sol_fop(l,j) + manure_kg(j) * + & forgp(it) + + end if + !!By Zhang for C/N cycling + !!=============================== !! add bacteria - #cfu/g * t(manure)/ha * 1.e6 g/t * ha/10,000 m^2 = 100. !! calculate ground cover gc = 0. diff --git a/src/grow.f b/src/grow.f index 2d8d499..1a1e114 100644 --- a/src/grow.f +++ b/src/grow.f @@ -247,7 +247,14 @@ subroutine grow bio_ms(j) = Max(bio_ms(j),0.) - + !!add by zhang + !!============ + if (cswat == 2) then + NPPC_d(j) = NPPC_d(j) + bioday * reg* 0.42 + end if + !!add by zhang + !!============ + !! calculate fraction of total biomass that is in the roots rwt(j) = .4 - .2 * phuacc(j) @@ -312,6 +319,7 @@ subroutine grow wshd_tstrs = wshd_tstrs + (1.-strstmp(j)) * hru_dafr(j) wshd_nstrs = wshd_nstrs + (1.-strsn(j)) * hru_dafr(j) wshd_pstrs = wshd_pstrs + (1.-strsp(j)) * hru_dafr(j) + wshd_astrs = wshd_astrs + (1.-strsa(j)) * hru_dafr(j) end if end if return diff --git a/src/gw_no3.f b/src/gw_no3.f index 04d05f2..acfdd68 100644 --- a/src/gw_no3.f +++ b/src/gw_no3.f @@ -7,7 +7,7 @@ subroutine gw_no3 !! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! alpha_bf(:) |days |alpha factor for groundwater recession curve +!! alpha_bf(:) |1/days |alpha factor for groundwater recession curve !! alpha_bfe(:)|none |Exp(-alpha_bf(:)) !! deepst(:) |mm H2O |depth of water in deep aquifer !! ihru |none |HRU number diff --git a/src/gwmod.f b/src/gwmod.f index c9447fa..eaa39be 100644 --- a/src/gwmod.f +++ b/src/gwmod.f @@ -7,7 +7,7 @@ subroutine gwmod !! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! alpha_bf(:) |days |alpha factor for groundwater recession curve +!! alpha_bf(:) |1/days |alpha factor for groundwater recession curve !! alpha_bfe(:)|none |Exp(-alpha_bf(:)) !! deepst(:) |mm H2O |depth of water in deep aquifer !! ihru |none |HRU number diff --git a/src/gwmod_deep.f b/src/gwmod_deep.f new file mode 100644 index 0000000..5a56a26 --- /dev/null +++ b/src/gwmod_deep.f @@ -0,0 +1,64 @@ + subroutine gwmod_deep + +!! ~ ~ ~ PURPOSE ~ ~ ~ +!! this subroutine estimates groundwater contribution to +!! streamflow + +!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! alpha_bfe_d(:)|none |Exp(-alpha_bf_d(:)) +!! deepst(:) |mm H2O |depth of water in deep aquifer +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! deepst(:) |mm H2O |depth of water in deep aquifer +!! gw_qdeep(:) |mm H2O |groundwater contribution to streamflow from deep aquifer from +!! |HRU on current day +!! gwseep |mm H2O |amount of water recharging deep aquifer on +!! |current day in HRU +!! shallst(:) |mm H2O |depth of water in shallow aquifer +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! j |none |HRU number +!! rchrg1 |mm H2O |amount of water entering deep aquifer on +!! |previous day +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ +!! Intrinsic: Max + +!! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ +!! revap is subtracted and rchrg is delayed (johnson, 1977) + + use parm + + integer :: j + real :: rchrg1 + + j = 0 + j = ihru + + rchrg1 = 0. + rchrg1 = gwseep + + +!! compute groundwater contribution to streamflow for day (deep aquifer) +! if (shallst(j) > gwqmn(j)) then + gw_qdeep(j) = gw_qdeep(j) * alpha_bfe_d(j) + gwseep * & + & (1. - alpha_bfe_d(j)) + ! else + ! gw_qdeep(j) = 0. + ! end if + + +!! remove ground water flow from deep aquifer storage + deepst(j) = deepst(j) - gw_qdeep(j) + + return + end diff --git a/src/harvestop.f b/src/harvestop.f index 1d7f6f4..ff8f16a 100644 --- a/src/harvestop.f +++ b/src/harvestop.f @@ -138,6 +138,35 @@ subroutine harvestop real :: hiad1, wur, clip, yieldn, yieldp, clipn, clipp real :: yldpst, clippst, rtresnew + + !!add by zhang + !!=================== + real :: BLG1, BLG2, BLG3, CLG, sf + real :: sol_min_n, resnew, resnew_n, resnew_ne + real :: LMF, LSF, LSLF, LSNF,LMNF + real :: RLN, RLR + orgc_f = 0. + BLG1 = 0. + BLG2 = 0. + BLG3 = 0. + CLG = 0. + sf = 0. + sol_min_n = 0. + resnew = 0. + resnew_n = 0. + resnew_ne = 0. + LMF = 0. + LSF = 0. + LSLF = 0. + LSNF = 0. + LMNF = 0. + + RLN = 0. + RLR = 0. + !!add by zhang + !!=================== + + j = 0 j = ihru @@ -234,11 +263,132 @@ subroutine harvestop clipn = Max(clipn,0.) clipp = Max(clipp,0.) + !!add by zhang + !!===================== + !!use idplt(:,:,:) to calculate the crop type, then + !! decide which type of crop yield should be used. + if (cswat == 2) then + grainc_d(j) = grainc_d(j)+ yield * 0.42 + rsdc_d(j) = rsdc_d(j)+(clip+yield) * 0.42 + end if + !!add by zhang + !!===================== + + !! add clippings to residue and organic n and p sol_rsd(1,j) = sol_rsd(1,j) + clip sol_fon(1,j) = clipn + sol_fon(1,j) sol_fop(1,j) = clipp + sol_fop(1,j) + !!insert new biomss by zhang + !!=============================== + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 !BLG1/BLG2 + BLG2 = 0.99 + BLG3 = 0.10 !BLG2 + !CALL ASCRV(BLG(1,I),BLG(2,I),.5,1.) + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+ + & EXP(BLG1-BLG2*phuacc(j))) + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = clip + resnew_n = clipn + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + !RLR is the fraction of lignin in the added residue + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + !In most cases, lignin content in residue should be less than 30% + !Therefore, RLR is expected to be less than 0.3 + !In the future, we may want to add a check make sure LMF is less than 1.0 - RLR. + !this would help to avoid sol_LS becoming less than sol_LSL + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + !In Jimmy's code, lignin added to sol_LSL is calculated as RLR*LSF*resnew + !However, I think we should use RLR*resnew; Confirmed with Jimmy + !sol_LSL(1,j) = sol_LSL(1,j) + RLR* LSF * resnew + sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew + + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + !In allignment with the sol_LSL calculation, sol_LSLC is also changed + !sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*LSF * resnew + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42+resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!============================= + + + !! Calculation for dead roots allocations, resetting phenology, updating other pools ff3 = 0. @@ -292,6 +442,110 @@ subroutine harvestop sol_rsd(l,j) = sol_rsd(l,j) + rtfr(l) * rtresnew sol_fon(l,j) = sol_fon(l,j) + rtfr(l) * rtresn sol_fop(l,j) = sol_fop(l,j) + rtfr(l) * rtresp + + !!insert new biomss by zhang + !!============================= + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + rsdc_d(j) = rsdc_d(j)+rtfr(l) * rtresnew * 0.42 + + BLG3 = 0.10 + BLG1 = 0.01/0.10 + BLG2 = 0.99 + + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+ + & EXP(BLG1-BLG2*phuacc(j))) + + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(l,j)+sol_nh3(l,j)) + + resnew = rtfr(l) * rtresnew + !resnew_n = resnew * pltfr_n(j) + !resnew_ne = resnew_n + sf * sol_min_n + resnew_n = rtfr(l) * rtresn + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(l,j) = sol_LM(l,j) + LMF * resnew + sol_LS(l,j) = sol_LS(l,j) + LSF * resnew + + + !here a simplified assumption of 0.5 LSL + LSLF = 0.0 + LSLF = CLG + + sol_LSL(l,j) = sol_LSL(l,j) + RLR* LSF * resnew + sol_LSC(l,j) = sol_LSC(l,j) + 0.42*LSF * resnew + + sol_LSLC(l,j) = sol_LSLC(l,j) + RLR*0.42*LSF * resnew + sol_LSLNC(l,j) = sol_LSC(l,j) - sol_LSLC(1,j) + + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(l,j) = sol_LSN(l,j) + 0.42 * LSF * resnew / 150 + sol_LMN(l,j) = sol_LMN(l,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(l,j) = sol_LSN(l,j) + resnew_ne + sol_LMN(l,j) = sol_LMN(l,j) + 1.E-25 + end if + + + + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(l,j) = sol_LMC(l,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!============================= end do rtfr = 0. diff --git a/src/harvgrainop.f b/src/harvgrainop.f index 6cc2b15..f5b0cbc 100644 --- a/src/harvgrainop.f +++ b/src/harvgrainop.f @@ -167,7 +167,16 @@ subroutine harvgrainop if (yield < 0.) yield = 0. yield = yield * harveff - + !!add by zhang + !!==================== + !!use idplt(:,:,:) to calculate the crop type, then + !! decide which type of crop yield should be used. + if (cswat == 2) then + grainc_d(j) = grainc_d(j)+ yield * 0.42 + end if + !!add by zhang + !!==================== + !! calculate nutrients removed with yield yieldn = 0. yieldp = 0. diff --git a/src/harvkillop.f b/src/harvkillop.f index 351c22d..74bf39d 100644 --- a/src/harvkillop.f +++ b/src/harvkillop.f @@ -130,6 +130,30 @@ subroutine harvkillop !! real :: wur, hiad1, yield, yieldn, yieldp, yldpst real :: wur, hiad1, yieldn, yieldp, yldpst real :: resnew, rtresnew + + + !!By Zhang + !!============= + real :: BLG1, BLG2, BLG3, CLG, sf + real :: sol_min_n, resnew_n, resnew_ne + real :: LMF, LSF, LSLF, LSNF,LMNF + orgc_f = 0. + BLG1 = 0. + BLG2 = 0. + BLG3 = 0. + CLG = 0. + sf = 0. + sol_min_n = 0. + resnew = 0. + resnew_n = 0. + resnew_ne = 0. + LMF = 0. + LSF = 0. + LSLF = 0. + LSNF = 0. + LMNF = 0. + !!By Zhang + !!================== j = 0 @@ -205,6 +229,19 @@ subroutine harvkillop ! I would avoid this check, it is ! safer to know if variable is negative + !!add by zhang + !!================= + !!use idplt(:,:,:) to calculate the crop type, then + !! decide which type of crop yield should be used. + if (cswat == 2) then + grainc_d(j) = grainc_d(j) + yield * 0.42 + stoverc_d(j) = stoverc_d(j)+(bio_ms(j)-yield-rtresnew)*0.42*xx + rsdc_d(j) = rsdc_d(j) + resnew * 0.42 + rsdc_d(j) = rsdc_d(j) + rtresnew * 0.42 + end if + !!add by zhang + !!================= + !! calculate nutrients removed with yield yieldn = 0. yieldp = 0. @@ -229,11 +266,222 @@ subroutine harvkillop sol_fon(1,j) = Max(sol_fon(1,j),0.) sol_fop(1,j) = Max(sol_fop(1,j),0.) + + !!insert new biomss by zhang + !!================================= + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+EXP(BLG1-BLG2*phuacc(j))) + + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = resnew + resnew_n = ff1 * (plantn(j) - yieldn) + resnew_ne = resnew_n + sf * sol_min_n + + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + !RLN is the ratio of lignin to nitrogen in the newly added residue + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/(resnew+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + !LSLF = 0.0 + !LSLF = CLG + + sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_n >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_n - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_n + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=============================== + + !! allocate dead roots, N, P to soil layers do l=1, sol_nly(j) sol_rsd(l,j) = sol_rsd(l,j) + rtfr(l) *rtresnew sol_fon(l,j) = sol_fon(l,j) + rtfr(l) *ff2 * (plantn(j) - yieldn) sol_fop(l,j) = sol_fop(l,j) + rtfr(l) *ff2 * (plantp(j) - yieldp) + + !!insert new biomss by zhang + !!============================== + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+EXP(BLG1-BLG2*phuacc(j))) + + + if (l == 1) then + sf = 0.05 + else + sf = 0.1 + end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(l,j)+sol_nh3(l,j)) + + resnew = rtfr(l) *rtresnew + resnew_n = rtfr(l) *ff2 * (plantn(j) - yieldn) + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(l,j) = sol_LM(l,j) + LMF * resnew + sol_LS(l,j) = sol_LS(l,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + LSLF = 0.0 + LSLF = CLG + + sol_LSL(l,j) = sol_LSL(l,j) + RLR* LSF * resnew + sol_LSC(l,j) = sol_LSC(l,j) + 0.42*LSF * resnew + + sol_LSLC(l,j) = sol_LSLC(l,j) + RLR*0.42*LSF * resnew + sol_LSLNC(l,j) = sol_LSC(l,j) - sol_LSLC(l,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(l,j) = sol_LSN(l,j) + 0.42 * LSF * resnew / 150 + sol_LMN(l,j) = sol_LMN(l,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(l,j) = sol_LSN(l,j) + resnew_ne + sol_LMN(l,j) = sol_LMN(l,j) + 1.E-25 + end if + + !LSNF = sol_LSN(l,j)/(sol_LS(l,j)+1.E-5) + + sol_LMC(l,j) = sol_LMC(l,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(l,j)/(sol_LM(l,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(l,j) = sol_no3(l,j) * (1-sf) + sol_nh3(l,j) = sol_nh3(l,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=============================== + end do !! adjust foliar pesticide for plant removal diff --git a/src/header.f b/src/header.f index 6ecc13b..45a697f 100644 --- a/src/header.f +++ b/src/header.f @@ -31,7 +31,7 @@ subroutine header & " PETmm"," ETmm"," SW_INITmm"," SW_ENDmm", & & " PERCmm"," GW_RCHGmm"," DA_RCHGmm"," REVAPmm", & & " SA_IRRmm"," DA_IRRmm"," SA_STmm"," DA_STmm", & - & "SURQ_GENmm","SURQ_CNTmm"," TLOSSmm"," LATQmm", & + & "SURQ_GENmm","SURQ_CNTmm"," TLOSSmm"," LATQGENmm", & & " GW_Qmm"," WYLDmm"," DAILYCN"," TMP_AVdgC", & & " TMP_MXdgC"," TMP_MNdgC","SOL_TMPdgC","SOLARMJ/m2", & & " SYLDt/ha"," USLEt/ha","N_APPkg/ha","P_APPkg/ha", & @@ -45,7 +45,8 @@ subroutine header & " TMP_STRS"," N_STRS"," P_STRS"," BIOMt/ha", & & " LAI"," YLDt/ha"," BACTPct "," BACTLPct", & & " WTAB CLIm"," WTAB SOLm"," SNOmm"," CMUPkg/ha", & - & "CMTOTkg/ha"," QTILEmm"," TNO3kg/ha"," LNO3kg/ha"/) + & "CMTOTkg/ha"," QTILEmm"," TNO3kg/ha"," LNO3kg/ha", & + & " GW_Q_Dmm"," LATQCNTmm"/) !! numbers printed to VB interface HRU output file @@ -54,7 +55,8 @@ subroutine header &293,303,313,323,333,343,353,363,373,383,393,403,413, & &423,433,443,453,463,473,483,493,503,513,523,533,543, & &553,563,573,583,593,603,613,623,633,643,653,663,673, & - &683,693,703,713,723,733,743,753,763,773,783,793/) + &683,693,703,713,723,733,743,753,763,773,783,793,803, & + &813/) !! column headers for subbasin output file hedb = (/" PRECIPmm"," SNOMELTmm"," PETmm"," ETmm", & diff --git a/src/headout.f b/src/headout.f index 10e27ed..e8cec7e 100644 --- a/src/headout.f +++ b/src/headout.f @@ -226,10 +226,11 @@ subroutine headout return 1000 format ('1',/t5,a80,t105,2(i2,'/'),i4,5x,2(i2,':'),i2) 1010 format (/(t5,20a4)) - 1020 format (//'LULC HRU GIS SUB MGT MON',' AREAkm2', - * 76(a10)," GISnum") + 1020 format (//'LULC HRU GIS SUB MGT MON',' AREAkm2', & + & 78(a10)) + ! * 76(a10)," GISnum") 1021 format (//'LULC HRU GIS SUB MGT MO DA YR', & - &' AREAkm2', 76(a10)) + &' AREAkm2', 78(a10)) 1030 format (//6x,' SUB GIS MON AREAkm2',22(a10)) 1040 format (//7x,'RCH GIS MON AREAkm2',56a12) 1041 format (//7x,'RCH GIS DAY DET AREAkm2',45a12) diff --git a/src/hhnoqual.f b/src/hhnoqual.f index a2cc4b8..a99107a 100644 --- a/src/hhnoqual.f +++ b/src/hhnoqual.f @@ -102,12 +102,12 @@ subroutine hhnoqual jrch = inum1 !! hourly loop - do ii = 1, 24 + do ii = 1, nstep !! initialize water flowing into reach wtrin = 0. wtrin = hhvaroute(2,inum2,ii) * (1. - rnum1) - if (hrtwtr(ii) / 3600. > 0.01 .and. wtrin > 0.01) then + if (hrtwtr(ii) / (idt * 60.) > 0.01 .and. wtrin > 0.01) then !! concentrations !! initialize inflow concentrations chlin = 0. @@ -303,16 +303,16 @@ subroutine hhnoqual !! end hourly loop !! set end of day concentrations - algae(jrch) = halgae(24) - chlora(jrch) = hchla(24) - organicn(jrch) = horgn(24) - ammonian(jrch) = hnh4(24) - nitriten(jrch) = hno2(24) - nitraten(jrch) = hno3(24) - organicp(jrch) = horgp(24) - disolvp(jrch) = hsolp(24) - rch_cbod(jrch) = hbod(24) - rch_dox(jrch) = hdisox(24) + algae(jrch) = halgae(nstep) + chlora(jrch) = hchla(nstep) + organicn(jrch) = horgn(nstep) + ammonian(jrch) = hnh4(nstep) + nitriten(jrch) = hno2(nstep) + nitraten(jrch) = hno3(nstep) + organicp(jrch) = horgp(nstep) + disolvp(jrch) = hsolp(nstep) + rch_cbod(jrch) = hbod(nstep) + rch_dox(jrch) = hdisox(nstep) if (algae(jrch) < 1.e-6) algae(jrch) = 0.0 if (chlora(jrch) < 1.e-6) chlora(jrch) = 0.0 diff --git a/src/hhwatqual.f b/src/hhwatqual.f index 8ac31c6..f86b947 100644 --- a/src/hhwatqual.f +++ b/src/hhwatqual.f @@ -236,12 +236,12 @@ subroutine hhwatqual jrch = inum1 !! hourly loop - do ii = 1, 24 + do ii = 1, nstep !! initialize water flowing into reach wtrin = 0. wtrin = hhvaroute(2,inum2,ii) * (1. - rnum1) - if (hrtwtr(ii) / 3600. > 0.01) then + if (hrtwtr(ii) / (idt * 60.) > 0.01) then !! concentrations !! initialize inflow concentrations chlin = 0. @@ -589,16 +589,16 @@ subroutine hhwatqual !! end hourly loop !! set end of day concentrations - algae(jrch) = halgae(24) - chlora(jrch) = hchla(24) - organicn(jrch) = horgn(24) - ammonian(jrch) = hnh4(24) - nitriten(jrch) = hno2(24) - nitraten(jrch) = hno3(24) - organicp(jrch) = horgp(24) - disolvp(jrch) = hsolp(24) - rch_cbod(jrch) = hbod(24) - rch_dox(jrch) = hdisox(24) + algae(jrch) = halgae(nstep) + chlora(jrch) = hchla(nstep) + organicn(jrch) = horgn(nstep) + ammonian(jrch) = hnh4(nstep) + nitriten(jrch) = hno2(nstep) + nitraten(jrch) = hno3(nstep) + organicp(jrch) = horgp(nstep) + disolvp(jrch) = hsolp(nstep) + rch_cbod(jrch) = hbod(nstep) + rch_dox(jrch) = hdisox(nstep) if (algae(jrch) < 1.e-6) algae(jrch) = 0.0 if (chlora(jrch) < 1.e-6) chlora(jrch) = 0.0 diff --git a/src/hmeas.f b/src/hmeas.f index e8331a7..00482c6 100644 --- a/src/hmeas.f +++ b/src/hmeas.f @@ -103,6 +103,8 @@ subroutine hmeas end do return - 5200 format (7x,300f8.3) - 5300 format (i4,i3,300f8.3) +! 5200 format (7x,300f8.3) +! 5300 format (i4,i3,300f8.3) + 5200 format (7x,1800f8.3) + 5300 format (i4,i3,1800f8.3) end diff --git a/src/hruaa.f b/src/hruaa.f index 4372964..d9704fd 100644 --- a/src/hruaa.f +++ b/src/hruaa.f @@ -261,6 +261,10 @@ subroutine hruaa(years) pdvas(75) = hruaao(68,j) !! latno3 - output.hru pdvas(76) = hruaao(69,j) +!! gw deep + pdvas(77) = hruaao(70,j) +!! latq contribution + pdvas(78) = hruaao(71,j) @@ -304,11 +308,11 @@ subroutine hruaa(years) return 1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,f4.1,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,8e10.3) + *e10.5,1x,e10.5,8e10.3,2f10.3) 2000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,f4.1,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,5e10.3,1x,i4) + *e10.5,1x,e10.5,5e10.3,2f10.3,1x,i4) 1001 format (a4,i7,1x,a5,a4,i5,1x,i4,1x,f4.1,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,5e10.3,1x,i4) + *e10.5,1x,e10.5,5e10.3,2f10.3,1x,i4) !! 1000 format (a4,i4,a5,a4,i5,1x,i4,1x,f4.1,e10.5,66f10.3,1x, !! *e10.5,1x,e10.5,5e10.3,1x,i4) !! 2000 format (a4,i5,1x,i8,1x,i4,1x,i4,1x,f4.1,e10.5,73f10.3,1x,i4) diff --git a/src/hruallo.f b/src/hruallo.f index c63268e..e05c806 100644 --- a/src/hruallo.f +++ b/src/hruallo.f @@ -1,4 +1,4 @@ - subroutine hruallo(hru) + subroutine hruallo !! ~ ~ ~ PURPOSE ~ ~ ~ !! This subroutine calculates the number of management operation types, etc. @@ -66,24 +66,23 @@ subroutine hruallo(hru) use parm - integer, intent (in) :: hru character (len=13) :: hrufile, mgtfile, solfile, chmfile character (len=80) :: titldum integer :: eof, j, k, lyrtot, rot, plt, ap_f, ap_p, ap_t, ap_i integer :: grz, cut, mgt1i, pstnum, ii, ap_r, ap_s, kll, hkll integer :: ap_ai, ap_af, mgt_op, ap_cf, ap_cc, ap_ci, jj + integer :: iopera_sub real :: depth(25) -!! skip subbasin input data - jj = 1 - read (25,6000) titldum - do j = 1, 3 - read (25,6000) titldum + do j= mhru1, mhru mgtfile = "" solfile = "" chmfile = "" - read (25,5300) hrufile, mgtfile, solfile, chmfile - if (hrufile /= ' ') then + read (25,5300,iostat=eof)hrufile, mgtfile, solfile, chmfile, ilnds + if (eof < 0) return + if (ilnds > 0) then + ils_nofig = 1 + end if call caps(mgtfile) call caps(solfile) call caps(chmfile) @@ -104,113 +103,30 @@ subroutine hruallo(hru) if (depth(k) <= 0.001) exit end do mlyr = Max(mlyr,lyrtot) - open (10,file=mgtfile) - !! calculate maximum number of years in a rotation - rot = 0 - do k = 1, 28 - read (10,6000) titldum - end do - read (10,*) rot - mnr = Max(mnr,rot) - read (10,6000) titldum - !! calculate maximum number of crops grown in a year - nopp = 0 - - do k = 1, rot - do - mgt_op = 0 - mgt1i = 0 - read (10,6300) mgt_op, mgt1i - if (mgt_op == 4 .and. mgt1i > 0) pstflg(mgt1i) = 1 - if (mgt_op == 0) exit - - nopp = nopp + 1 - - - end do - mapp = Max(mapp,nopp) - - end do - open (11,file=chmfile) - eof = 0 - do - do k = 1, 11 - read (11,6000,iostat=eof) titldum - if (eof < 0) exit - end do - if (eof < 0) exit - do - pstnum = 0 - read (11,*,iostat=eof) pstnum - if (eof < 0) exit - if (pstnum > 0) pstflg(pstnum) = 1 - end do - if (eof < 0) exit - end do - close (11) - close (10) close (9) - jj = jj + 1 - end if - end do - - read (25,6000) titldum - do j = jj, hru - mgtfile = "" - solfile = "" - chmfile = "" - read (25,5300) hrufile, mgtfile, solfile, chmfile - call caps(mgtfile) - call caps(solfile) - call caps(chmfile) - open (9,file=solfile,recl=350) - !! calculate # of soil layers in profile - depth = 0. - lyrtot = 0 - read (9,6000) titldum - read (9,6000) titldum - read (9,6000) titldum - read (9,6000) titldum - read (9,6000) titldum - read (9,6000) titldum - read (9,6000) titldum - read (9,6100) (depth(k), k = 1, 25) - do k = 1, 25 - if (depth(k) <= 0.001) lyrtot = k - 1 - if (depth(k) <= 0.001) exit - end do - mlyr = Max(mlyr,lyrtot) open (10,file=mgtfile) - !! calculate maximum number of years in a rotation - rot = 0 - do k = 1, 28 - read (10,6000) titldum - end do - read (10,*) rot - mnr = Max(mnr,rot) - !! calculate maximum number of crops grown in a year + +!! calculate max number of operations per hru + iopera_sub = 1 + mcri = 0 + do kk = 1, 30 read (10,6000) titldum - nopp = 0 - mcri = 0 - -!! do k = 1, rot - do - mgt_op = 0 - mgt1i = 0 - read (10,6300,iostat=eof) mgt_op, mgt1i - if (eof < 0) exit - if (mgt_op == 4 .and. mgt1i > 0) pstflg(mgt1i) = 1 - if (mgt_op == 1) then - mcri = mcri + 1 - end if - nopp = nopp + 1 - - end do - - mcr = Max(mcr,mcri) - mapp = Max(mapp,nopp) - -!! end do + end do + + do kk = 1, 1000 + read (10,6300,iostat=eof) mgt_op, mgt1i + if (eof < 0) exit + if (mgt_op == 1) then + mcri = mcri + 1 + end if + if (mgt_op == 4 .and. mgt1i > 0) pstflg(mgt1i) = 1 + iopera_sub = iopera_sub + 1 + end do + iopera = Max(iopera,iopera_sub) + mcr = Max(mcr,mcri) + + close (10) !! nubz test + open (11,file=chmfile) eof = 0 do @@ -227,18 +143,16 @@ subroutine hruallo(hru) end do if (eof < 0) exit end do - close (11) - close (10) - close (9) - end do - + close (11) + end do ! hru loop + return 5000 format (6a) 5001 format (a1,9x,5i6) 5002 format(a) 5100 format (20a4) 5200 format (10i4) - 5300 format (6a13) + 5300 format (4a13,52x,i6) 6000 format (a80) 6100 format (27x,25f12.2) 6200 format (1x,i3) diff --git a/src/hruday.f b/src/hruday.f90 similarity index 65% rename from src/hruday.f rename to src/hruday.f90 index d90cbb3..ab43730 100644 --- a/src/hruday.f +++ b/src/hruday.f90 @@ -186,6 +186,121 @@ subroutine hruday real, dimension (mhruo) :: pdvas, pdvs character (len=4) :: cropname + !!by zhang print out soil water + !!=============================== + integer :: ly + real :: sumwater, sumwfsc, sumdepth, sat, wc, dp + real :: ssoilwater(100), swfsc(100) + real :: soilwater(11), wfsc(11), sum_depth(11) !10, 100, 200, 300, 400, ..., 1000 mm + !!by zhang print out soil water + !!=============================== + + + !!by zhang print out soil water + !!=============================== + if (cswat == 2) then + !fc = sol_fc(kk,j) + sol_wpmm(kk,j) ! units mm + !wc = sol_st(kk,j) + sol_wpmm(kk,j) ! units mm + !sat = sol_ul(kk,j) + sol_wpmm(kk,j) ! units mm + !void = sol_por(kk,j) * (1. - wc / sat) ! fraction + + soilwater(1) = 0. + wfsc(1) = 0. + sum_depth(1) = 10. + do k = 2, 11 + soilwater(k) = 0. + wfsc(k) = 0. + sum_depth(k) = 100. * (k -1) + end do + + wc = sol_st(1,ihru) + sol_wpmm(1,ihru) + sat = sol_ul(1,ihru) + sol_wpmm(1,ihru) + soilwater(1) = wc + wfsc(1) = sol_por(1,ihru) * (wc / sat) ! fraction + + if (sol_nly(ihru) .ge. 2) then + do k = 2, 11 + sumwater = 0. + sumwfsc = 0. + sumdepth = 0. + do ly = 2, sol_nly(ihru) + if (sol_z(ly-1,ihru) .ge. sum_depth(k-1) .and. sol_z(ly,ihru) .le. sum_depth(k)) then + + dp = sol_z(ly,ihru) - sol_z(ly-1,ihru) + if (dp .gt. 0.) then + wc = sol_st(ly,ihru) + sol_wpmm(ly,ihru)*(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + sat = sol_ul(ly,ihru) + sol_wpmm(ly,ihru)*(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + + + sumwater = sumwater + wc * dp + sumwfsc = sumwfsc + sol_por(ly,ihru) * (wc / sat) * dp + sumdepth = sumdepth + dp + end if + + elseif ((sol_z(ly-1,ihru) .gt. sum_depth(k-1) .and. sol_z(ly,ihru) .gt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .ge. sum_depth(k-1) .and. sol_z(ly,ihru) .gt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .gt. sum_depth(k-1) .and. sol_z(ly,ihru) .ge. sum_depth(k))) & + then + if (sol_z(ly-1,ihru) .le. sum_depth(k)) then + dp = sum_depth(k) - sol_z(ly-1,ihru) + if (dp .gt. 0.) then + wc = (sol_st(ly,ihru) + sol_wpmm(ly,ihru)) *(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + sat = (sol_ul(ly,ihru) + sol_wpmm(ly,ihru)) *(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + + + sumwater = sumwater + wc * dp + sumwfsc = sumwfsc + sol_por(ly,ihru) * (wc / sat) * dp + sumdepth = sumdepth + dp + end if + end if + elseif ((sol_z(ly-1,ihru) .lt. sum_depth(k-1) .and. sol_z(ly,ihru) .lt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .le. sum_depth(k-1) .and. sol_z(ly,ihru) .lt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .lt. sum_depth(k-1) .and. sol_z(ly,ihru) .le. sum_depth(k))) & + then + if (sol_z(ly,ihru) .ge. sum_depth(k-1)) then + dp = sol_z(ly,ihru) - sum_depth(k-1) + if (dp .gt. 0.) then + wc = (sol_st(ly,ihru) + sol_wpmm(ly,ihru))*(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + sat = (sol_ul(ly,ihru) + sol_wpmm(ly,ihru)) *(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + + + sumwater = sumwater + wc * dp + sumwfsc = sumwfsc + sol_por(ly,ihru) * (wc / sat) * dp + sumdepth = sumdepth + dp + end if + end if + + elseif ((sol_z(ly-1,ihru) .lt. sum_depth(k-1) .and. sol_z(ly,ihru) .gt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .le. sum_depth(k-1) .and. sol_z(ly,ihru) .gt. sum_depth(k)) & + .or. (sol_z(ly-1,ihru) .lt. sum_depth(k-1) .and. sol_z(ly,ihru) .ge. sum_depth(k))) & + then + dp = sum_depth(k) - sum_depth(k-1) + if (dp .gt. 0.) then + wc = (sol_st(ly,ihru) + sol_wpmm(ly,ihru))*(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + sat = (sol_ul(ly,ihru) + sol_wpmm(ly,ihru))*(dp/(sol_z(ly,ihru)-sol_z(ly-1,ihru))) + + + sumwater = sumwater + wc * dp + sumwfsc = sumwfsc + sol_por(ly,ihru) * (wc / sat) * dp + sumdepth = sumdepth + dp + end if + end if + end do !!End lyr + + if (sumdepth .gt. 0.) then + soilwater(k) = sumwater / sumdepth + wfsc(k) = sumwfsc / sumdepth ! fraction + end if + + end do !!end k + + + end if + end if + !!by zhang print out soil water + !!=============================== + + j = 0 j = ihru sb = hru_sub(j) @@ -215,7 +330,7 @@ subroutine hruday pdvas(15) = shallst(j) pdvas(16) = deepst(j) pdvas(17) = surfq(j) - pdvas(18) = qday + tloss + pdvas(18) = qday pdvas(19) = tloss pdvas(20) = latq(j) pdvas(21) = gw_q(j) @@ -282,7 +397,10 @@ subroutine hruday ! tileno3 - output.hru pdvas(75) = tileno3(j) ! latno3 - output.hru - pdvas(76) = latno3(j) + pdvas(76) = latno3(j) +! groundwater deep + pdvas(77) = gw_qdeep(j) + pdvas(78) = latq(j) - lpndloss - lwetloss ii = icl(iida) @@ -306,12 +424,12 @@ subroutine hruday & hruno(j), sb, nmgt(j), i_mo, icl(iida), iyr, hru_km(j), & & (pdvs(ii), ii = 1, itots) 1002 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i2,1x,i2,1x,i4,1x,e10.5, & - & 66f10.3,1x,e10.5,1x,e10.5,8e10.3) + & 66f10.3,1x,e10.5,1x,e10.5,8e10.3,2f10.3) !! added for binary files 3/25/09 gsm line below and write (33333 if (ia_b == 1) then - write (33333) j, hrugis(j), sb, - * nmgt(j), iida, hru_km(j), (pdvs(ii), ii = 1, itots) + write (33333) j, hrugis(j), sb, & + & nmgt(j), iida, hru_km(j), (pdvs(ii), ii = 1, itots) endif else if (isproj == 1) then write (21,1000) cropname, j, subnum(j), hruno(j), sb, & @@ -323,7 +441,7 @@ subroutine hruday & sb, nmgt(j), i_mo, icl(iida), iyr, hru_km(j), & & (pdvs(ii), ii = 1, itots), iyr 1003 format(a4,i5,1x,a5,a4,i5,1x,i4,1x,i2,1x,i2,1x,i4,1x,e10.5,66f10.3,& - &1x,e10.5,1x,e10.5,8e10.3,1x,i4) + &1x,e10.5,1x,e10.5,8e10.3,f10.3,1x,i4) end if else if (iscen == 1 .and. isproj == 0) then @@ -350,10 +468,76 @@ subroutine hruday end if end if + + !!add by zhang + !!output carbon realted variables + !!================================= + if (cswat == 2) then + if (j == 1) then + tot_mass = 0. + tot_cmass = 0. + tot_nmass = 0. + tot_LSC = 0. + tot_LMC = 0. + tot_HSC = 0. + tot_HPC = 0. + tot_BMC = 0. + tot_pmass = 0. + tot_solp = 0. + tot_no3_nh3 =0. + do k=1,sol_nly(j) + sol_mass = 0. + if (k == 1) then + sol_mass = (10) / 1000.* 10000. * sol_bd(k,j)* 1000. * & + (1- sol_rock(k,j) / 100.) + else + sol_mass = (sol_z(k,j) - sol_z(k-1,j)) / 1000.* 10000. & + * sol_bd(k,j)* 1000. * (1- sol_rock(k,j) / 100.) + end if + sol_cmass = 0. + sol_cmass = sol_LSC(k,j)+sol_LMC(k,j)+sol_HPC(k,j)+sol_HSC(k,j) & + +sol_BMC(k,j) + sol_nmass = 0. + sol_nmass = sol_LSN(k,j)+sol_LMN(k,j)+sol_HPN(k,j)+sol_HSN(k,j) & + +sol_BMN(k,j) + write (98,9000) iyr, i, k, j, sol_mass,sol_cmass, & + sol_nmass,sol_LS(k,j),sol_LM(k,j), & + sol_LSC(k,j),sol_LMC(k,j),sol_HSC(k,j),sol_HPC(k,j), & + sol_BMC(k,j),sol_LSN(k,j),sol_LMN(k,j),sol_HPN(k,j), & + sol_HSN(k,j),sol_BMN(k,j),sol_no3(k,j),sol_fop(k,j), & + sol_orgp(k,j),sol_solp(k,j) + + tot_mass = tot_mass + sol_mass + tot_cmass = tot_cmass + sol_cmass + tot_nmass = tot_nmass + sol_nmass + tot_LSC = tot_LSC + sol_LSC(k,j) + tot_LMC = tot_LMC + sol_LMC(k,j) + tot_HSC = tot_HSC + sol_HSC(k,j) + tot_HPC = tot_HPC + sol_HPC(k,j) + tot_BMC = tot_BMC + sol_BMC(k,j) + tot_pmass =tot_pmass+ sol_orgp(k,j) + sol_fop(k,j) & + + sol_solp(k,j) + tot_solp = tot_solp + sol_solp(k,j) + + tot_no3_nh3 = tot_no3_nh3 + sol_no3(k,j) + sol_nh3(k,j) + end do + + write (100,9001) iyr, i, j, rsdc_d(j), sedc_d(j), percc_d(j), & + latc_d(j),emitc_d(j), grainc_d(j), surfqc_d(j), stoverc_d(j), & + NPPC_d(j), foc_d(j),rspc_d(j),tot_mass,tot_cmass,tot_nmass, & + tot_LSC,tot_LMC,tot_HSC,tot_HPC,tot_BMC, & + bio_ms(j)*0.42, rwt(j), tot_no3_nh3,wdntl,etday,tillage_factor(j), & + (soilwater(ii), ii = 1, 11), (wfsc(ii), ii = 1, 11) + end if + end if + !!add by zhang + !!output carbon realted variables + !!================================= + return -1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,8e10.3,1x,i4) -1001 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,8e10.3) +1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x,e10.5,1x,e10.5,8e10.3,2f10.3,1x,i4) +1001 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x,e10.5,1x,e10.5,8e10.3,2f10.3) +9000 format(i4,i4,i2,i8,21(f16.3)) +9001 format(i4,i4,i8,48(f16.3)) end diff --git a/src/hrumon.f b/src/hrumon.f index 7eabeeb..35d717b 100644 --- a/src/hrumon.f +++ b/src/hrumon.f @@ -274,6 +274,10 @@ subroutine hrumon pdvas(75) = hrumono(68,j) !! latno3 - output.hru pdvas(76) = hrumono(69,j) +!! gwq deep + pdvas(77) = hrumono(70,j) +!! lat q continuous + pdvas(78) = hrumono(71,j) if (itots > 0) then ix = itots @@ -327,11 +331,11 @@ subroutine hrumon return 1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,8e10.3) + *e10.5,1x,e10.5,8e10.3,2f10.3) 2000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,5e10.3,1x,i4) + *e10.5,1x,e10.5,5e10.3,2f10.3,1x,i4) 1001 format (a4,i7,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,3e10.3,1x,i4) + *e10.5,1x,e10.5,3e10.3,2f10.3,1x,i4) !1000 format (a4,i4,1x,i8,1x,i4,1x,i4,1x,i4,e10.5,66f10.3,1x, ! *e10.5,1x,e10.5,2e10.3,1x,i4) !2000 format (a4,i5,1x,i8,1x,i4,1x,i4,1x,i4,e10.5,70f10.3,1x,i4) diff --git a/src/hrupond.f b/src/hrupond.f index e193ad2..93d5b1a 100644 --- a/src/hrupond.f +++ b/src/hrupond.f @@ -102,7 +102,7 @@ subroutine hrupond use parm integer :: j - real :: cnv, pndsa, xx, yy + real :: cnv, pndsa, xx, yy, qdayi, latqi j = 0 j = ihru @@ -116,9 +116,17 @@ subroutine hrupond pndsa = bp1(j) * pnd_vol(j) ** bp2(j) !! calculate water flowing into pond for day - pndflwi = qdr(j) * 10. * hru_ha(j) * pnd_fr(j) - qdr(j) = qdr(j) - qdr(j) * pnd_fr(j) - + pndflwi = qday + latq(j) + pndflwi = pndflwi * 10. * hru_ha(j) * pnd_fr(j) + qdayi = qday + latqi = latq(j) + qday = qday * (1. - pnd_fr(j)) + latq(j) = latq(j) * (1. - pnd_fr(j)) + pndloss = qdayi - qday + lpndloss = latqi - latq(j) + qdr(j) = qdr(j) - pndloss - lpndloss +! qdr(j) = qdr(j) - qdr(j) * pnd_fr(j) + !! calculate sediment loading to pond for day pndsedin = sedyld(j) * (pnd_fr(j) - pndsa / hru_ha(j)) pndsanin = sanyld(j) * (pnd_fr(j) - pndsa / hru_ha(j)) @@ -171,6 +179,7 @@ subroutine hrupond call pond(j) !! compute water leaving pond + qday= qday + pndflwo / cnv qdr(j) = qdr(j) + pndflwo / cnv !! compute sediment leaving pond diff --git a/src/hruyr.f b/src/hruyr.f index a1a3c0f..89c8479 100644 --- a/src/hruyr.f +++ b/src/hruyr.f @@ -252,6 +252,10 @@ subroutine hruyr pdvas(75) = hruyro(68,j) !! latno3 - output.hru pdvas(76) = hruyro(69,j) +!! gwq deep + pdvas(77) = hruyro(70,j) +!! latq contribution + pdvas(78) = hruyro(71,j) if (ipdvas(1) > 0) then do ii = 1, itots @@ -293,11 +297,11 @@ subroutine hruyr return 1000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,8e10.3) + *e10.5,1x,e10.5,8e10.3,2f10.3) 2000 format (a4,i5,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,5e10.3,1x,i4) + *e10.5,1x,e10.5,5e10.3,2f10.3,1x,i4) 1001 format (a4,i7,1x,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, - *e10.5,1x,e10.5,3e10.3,1x,i4) + *e10.5,1x,e10.5,3e10.3,2f10.3,1x,i4) !!1000 format (a4,i4,a5,a4,i5,1x,i4,1x,i4,e10.5,66f10.3,1x, diff --git a/src/hydroinit.f b/src/hydroinit.f index d94ab45..33779ca 100644 --- a/src/hydroinit.f +++ b/src/hydroinit.f @@ -6,7 +6,7 @@ subroutine hydroinit !! the coefficient for the peak runoff rate equation, and lateral flow travel !! time. -!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ +!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~1 !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ch_l1(:) |km |longest tributary channel length in subbasin @@ -156,7 +156,7 @@ subroutine hydroinit if (ievent > 1) then !! compute unit hydrograph for computing subbasin hydrograph from direct runoff - do isb = 1, msub - 1 + do isb = 1, msub ql = 0. sumq = 0. diff --git a/src/killop.f b/src/killop.f index d492b86..acb98c5 100644 --- a/src/killop.f +++ b/src/killop.f @@ -75,7 +75,31 @@ subroutine killop integer :: j, k real :: resnew - + + !!by zhang + !!==================== + real :: BLG1, BLG2, BLG3, CLG, sf + real :: sol_min_n, resnew_n, resnew_ne + real :: LMF, LSF, LSLF, LSNF,LMNF + orgc_f = 0. + BLG1 = 0. + BLG2 = 0. + BLG3 = 0. + CLG = 0. + sf = 0. + sol_min_n = 0. + resnew = 0. + resnew_n = 0. + resnew_ne = 0. + LMF = 0. + LSF = 0. + LSLF = 0. + LSNF = 0. + LMNF = 0. + !!by zhang + !!==================== + + j = 0 j = ihru @@ -98,11 +122,220 @@ subroutine killop sol_fon(1,j) = Max(sol_fon(1,j),0.) sol_fop(1,j) = Max(sol_fop(1,j),0.) + !!insert new biomss by zhang + !!================================= + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+EXP(BLG1-BLG2*phuacc(j))) + + + !if (k == 1) then + sf = 0.05 + !else + !sf = 0.1 + !end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(1,j)+sol_nh3(1,j)) + + resnew = resnew + resnew_n = ff1 * (plantn(j) - yieldn) + resnew_ne = resnew_n + sf * sol_min_n + + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/(resnew+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(1,j) = sol_LM(1,j) + LMF * resnew + sol_LS(1,j) = sol_LS(1,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + LSLF = 0.0 + LSLF = CLG + + sol_LSL(1,j) = sol_LSL(1,j) + RLR* LSF * resnew + sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew + + sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*LSF * resnew + sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_n >= (0.42 * LSF * resnew /150)) then + sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150 + sol_LMN(1,j) = sol_LMN(1,j) + resnew_n - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(1,j) = sol_LSN(1,j) + resnew_n + sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25 + end if + + !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5) + + sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(1,j) = sol_no3(1,j) * (1-sf) + sol_nh3(1,j) = sol_nh3(1,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=============================== + !! allocate dead roots, N, P to soil layers do l=1, sol_nly(j) sol_rsd(l,j) = sol_rsd(l,j) + rtfr(l) * rtresnew sol_fon(l,j) = sol_fon(l,j) + rtfr(l) * plantn(j) * rwt(j) sol_fop(l,j) = sol_fop(l,j) + rtfr(l) * plantp(j) * rwt(j) + + !!insert new biomss by zhang + !!============================== + if (cswat == 2) then + !!all the lignin from STD is assigned to LSL, + !!add STDL calculation + !! + !sol_LSL(k,ihru) = sol_STDL(k,ihru) + !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK)) + ! 52 BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY + ! 53 BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY + !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10 + !SUBROUTINE ASCRV(X1,X2,X3,X4) + !EPIC0810 + !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS. + !USE PARM + !XX=LOG(X3/X1-X3) + !X2=(XX-LOG(X4/X2-X4))/(X4-X3) + !X1=XX+X3*X2 + !RETURN + !END + !HUI(JJK)=HU(JJK)/XPHU + + BLG1 = 0.01/0.10 + BLG2 = 0.99 + BLG3 = 0.10 + XX = log(0.5/BLG1-0.5) + BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5) + BLG1 = XX + 0.5*BLG2 + CLG=BLG3*phuacc(j)/(phuacc(j)+EXP(BLG1-BLG2*phuacc(j))) + + + if (l == 1) then + sf = 0.05 + else + sf = 0.1 + end if + + !kg/ha + sol_min_n = 0. + sol_min_n = (sol_no3(l,j)+sol_nh3(l,j)) + + resnew = rtfr(l) * rtresnew + resnew_n = rtfr(l) *ff2 * (plantn(j) - yieldn) + resnew_ne = resnew_n + sf * sol_min_n + !Not sure 1000 should be here or not! + !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5)) + RLN = (resnew * CLG/(resnew_n+1.E-5)) + RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5)) + + LMF = 0.85 - 0.018 * RLN + if (LMF <0.01) then + LMF = 0.01 + else + if (LMF >0.7) then + LMF = 0.7 + end if + end if + !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then + ! LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5)) + !else + ! LMF = 0. + !end if + + LSF = 1 - LMF + + sol_LM(l,j) = sol_LM(l,j) + LMF * resnew + sol_LS(l,j) = sol_LS(l,j) + LSF * resnew + + + + !here a simplified assumption of 0.5 LSL + !LSLF = 0.0 + !LSLF = CLG + + sol_LSL(l,j) = sol_LSL(l,j) + RLR*resnew + sol_LSC(l,j) = sol_LSC(l,j) + 0.42*LSF * resnew + + sol_LSLC(l,j) = sol_LSLC(l,j) + RLR*0.42*resnew + sol_LSLNC(l,j) = sol_LSC(l,j) - sol_LSLC(l,j) + + !X3 = MIN(X6,0.42*LSF * resnew/150) + + if (resnew_ne >= (0.42 * LSF * resnew /150)) then + sol_LSN(l,j) = sol_LSN(l,j) + 0.42 * LSF * resnew / 150 + sol_LMN(l,j) = sol_LMN(l,j) + resnew_ne - + & (0.42 * LSF * resnew / 150) + 1.E-25 + else + sol_LSN(l,j) = sol_LSN(l,j) + resnew_ne + sol_LMN(l,j) = sol_LMN(l,j) + 1.E-25 + end if + + !LSNF = sol_LSN(l,j)/(sol_LS(l,j)+1.E-5) + + sol_LMC(l,j) = sol_LMC(l,j) + 0.42 * LMF * resnew + !LMNF = sol_LMN(l,j)/(sol_LM(l,j) + 1.E-5) + + !update no3 and nh3 in soil + sol_no3(l,j) = sol_no3(l,j) * (1-sf) + sol_nh3(l,j) = sol_nh3(l,j) * (1-sf) + end if + !!insert new biomss by zhang + !!=============================== + + end do if (hrupest(j) == 1) then diff --git a/src/main.f b/src/main.f index 10933f2..3861d8a 100644 --- a/src/main.f +++ b/src/main.f @@ -55,13 +55,13 @@ program main use parm implicit none - prog = "SWAT June 26 2012 VER 2012/Rev 535" + prog = "SWAT Nov 14 2012 VER 2012/Rev 582" write (*,1000) - 1000 format(1x," SWAT2012 ",/, & - & " Rev. 535 ",/, & - & " Soil & Water Assessment Tool ",/, & - & " PC Version ",/, & + 1000 format(1x," SWAT2012 ",/, + & " Rev. 582 ",/, + & " Soil & Water Assessment Tool ",/, + & " PC Version ",/, & " Program reading from file.cio . . . executing",/) !! process input @@ -82,7 +82,6 @@ program main call readfig call readatmodep call readinpt - call readparmfile !! BK read and adjust parms call std1 call std2 call openwth diff --git a/src/modparm.f b/src/modparm.f index 3bcecd1..7c80eb5 100644 --- a/src/modparm.f +++ b/src/modparm.f @@ -14,9 +14,13 @@ module parm !! new arrays for routing units - real, dimension (:,:), allocatable :: hru_rufr - real, dimension (:), allocatable :: daru_km, gwq_ru - integer :: iru, mru, irch, isub, idum, mhyd_bsn, ipest + real, dimension (:,:), allocatable :: hru_rufr, daru_km, ru_k + real, dimension (:,:), allocatable :: ru_c, ru_eiq, ru_ovsl, ru_a + real, dimension (:,:), allocatable :: ru_ovs, ru_ktc + real, dimension (:), allocatable :: gwq_ru, qdayout + integer, dimension (:), allocatable :: ils2, ils2flag + integer :: iru, mru, irch, isub, idum, mhyd_bsn, ipest, ils_nofig + integer :: mhru1 integer, dimension (:), allocatable :: mhyd1 , irtun !! septic variables for output.std @@ -25,12 +29,13 @@ module parm real :: wshd_sepmm integer, dimension (:), allocatable :: isep_hru !! septic variables for output.std - real :: fixco, nfixmx, rsd_covco, buff_cf, vcrit, res_stlr_co + real :: fixco, nfixmx, rsd_covco, vcrit, res_stlr_co real :: wshd_sw, wshd_snob, wshd_pndfr, wshd_pndv, wshd_pndsed real :: wshd_wetfr, wshd_resfr, wshd_resha, wshd_pndha, percop real :: wshd_fminp, wshd_ftotn, wshd_fnh3, wshd_fno3, wshd_forgn real :: wshd_forgp, wshd_ftotp, wshd_yldn, wshd_yldp, wshd_fixn real :: wshd_pup, wshd_wstrs, wshd_nstrs, wshd_pstrs, wshd_tstrs + real :: wshd_astrs real :: wshd_hmn, wshd_rwn, wshd_hmp, wshd_rmn, wshd_dnit, ffcb real :: wshd_rmp, wshd_voln, wshd_nitn, wshd_pas, wshd_pal, wdpq real :: wshd_plch, wshd_raino3, ressedc, basno3f, basorgnf, wof_p @@ -40,6 +45,7 @@ module parm real :: wtabelo, timp, tilep, wt_shall real :: sq_rto real :: tloss, inflpcp, snomlt, snofall, fixn, qtile, crk, latlyr + real :: pndloss, wetloss,potloss, lpndloss, lwetloss real :: sedrch, fertn, sol_rd, cfertn, cfertp, sepday, bioday real :: sepcrk, sepcrktot, fertno3, fertnh3, fertorgn, fertsolp real :: fertorgp @@ -58,6 +64,7 @@ module parm real :: sbactrop, sbactrolp, sbactsedp, sbactsedlp, ep_max, wof_lp real :: sbactlchp, sbactlchlp, psp, rchwtr, resuspst, setlpst real :: bsprev, bssprev, spadyo, spadyev, spadysp, spadyrfv + real :: spadyosp real :: qday, usle_ei, al5, pndsedc, no3pcp, rcharea, volatpst real :: wetsedc, uobw, ubw, uobn, uobp, prf, respesti, wglpf real :: snocovmx, snocov1, snocov2, rexp, rcor, lyrtile, lyrtilex @@ -86,8 +93,8 @@ module parm ! Drainmod tile equations 01/2006 real, dimension (:), allocatable :: wat_tbl,sol_swpwt real, dimension (:,:), allocatable :: vwt - real :: re_bsn, sdrain_bsn - real :: drain_co_bsn, pc_bsn, latksatf_bsn + real :: re_bsn, sdrain_bsn, sstmaxd_bsn, r2adj + real :: drain_co_bsn, pc_bsn, latksatf_bsn ! Drainmod tile equations 01/2006 integer :: i_subhw, imgt, idlast, iwtr, ifrttyp, mo_atmo, mo_atmo1 integer :: ifirstatmo, iyr_atmo, iyr_atmo1 @@ -95,11 +102,11 @@ module parm integer :: mnr, myr, mcut, mgr, msubo, mrcho, isubwq, ffcst integer :: nhru, isproj, mo, nbyr, immo, nrch, nres, irte, i_mo integer :: icode, ihout, inum1, inum2, inum3, inum4, wndsim, ihru - integer :: inum5, icfac + integer :: inum5, inum6, inum7, inum8, icfac integer :: nrgage, ntgage, nrgfil, ntgfil, nrtot, nttot, mrech integer :: lao, igropt, npmx, irtpest, curyr, tmpsim, icrk, iihru ! Drainmod tile equations 01/2006 - integer :: itdrn, iwtdn + integer :: ismax, itdrn, iwtdn ! Drainmod tile equations 01/2006 integer :: mtil, mvaro, mrecd, idist, mudb, mrecm, mrecc, iclb integer :: mrecy, ipet, nyskip, ideg, ievent, slrsim, iopera @@ -112,8 +119,7 @@ module parm integer :: fcstcnt, icn, ised_det, mtran, idtill, motot integer, dimension(100) :: ida_lup, iyr_lup integer :: no_lup, no_up -! routing 5/3/2010 gsm per jga - integer :: rutot +! routing 5/3/2010 gsm per jga ! date character(len=8) :: date character(len=10) :: time @@ -300,7 +306,7 @@ module parm real, dimension (:), allocatable :: sub_cbod,sub_dox,sub_solpst real, dimension (:), allocatable :: sub_sorpst,sub_yorgn,sub_yorgp real, dimension (:), allocatable :: sub_bactp,sub_bactlp,sub_lat - real, dimension (:), allocatable :: sub_latq + real, dimension (:), allocatable :: sub_latq, sub_gwq_d,sub_tileq real, dimension (:), allocatable :: sub_dsan, sub_dsil, sub_dcla real, dimension (:), allocatable :: sub_dsag, sub_dlag @@ -380,7 +386,6 @@ module parm real, dimension (:), allocatable :: hlife_f,hlife_s,decay_s real, dimension (:), allocatable :: pst_wsol,pst_wof, irramt real, dimension (:), allocatable :: phusw, phusw_nocrop - real, dimension (:,:), allocatable :: pst_dep integer, dimension (:), allocatable :: nope, pstflg, nop integer, dimension (:), allocatable :: yr_skip, isweep integer, dimension (:), allocatable :: icrmx, nopmx @@ -411,7 +416,7 @@ module parm real, dimension (:), allocatable :: thalf,tnconc,tpconc,tno3conc real, dimension (:), allocatable :: fcimp,urbcn2 ! mapp = max number of applications - real :: sweepeff,frt_kg + real :: sweepeff,frt_kg, pst_dep !! added pst_dep to statement below 3/31/08 gsm !! burn 3/5/09 ! mnr = max number years of rotation @@ -430,7 +435,7 @@ module parm real, dimension (:,:,:), allocatable :: hhvaroute integer, dimension (:), allocatable :: icodes,ihouts,inum1s integer, dimension (:), allocatable :: inum2s,inum3s,inum4s - integer, dimension (:), allocatable :: inum5s + integer, dimension (:), allocatable :: inum5s,inum6s,inum7s,inum8s integer, dimension (:), allocatable :: subed character(len=10), dimension (:), allocatable :: recmonps character(len=10), dimension (:), allocatable :: reccnstps @@ -447,9 +452,9 @@ module parm real, dimension (:), allocatable :: pot_volx,potflwi,potsedi,wfsh real, dimension (:), allocatable :: pot_nsed,pot_no3l,newrti,gwno3 real, dimension (:), allocatable :: pot_sed,pot_no3,fsred,tmpavp - real, dimension (:), allocatable :: evpot, dis_stream + real, dimension (:), allocatable :: evpot, dis_stream, pot_solpl real, dimension (:), allocatable :: sed_con, orgn_con, orgp_con - real, dimension (:), allocatable :: soln_con, solp_con + real, dimension (:), allocatable :: soln_con, solp_con, pot_k integer, dimension (:), allocatable :: ioper integer, dimension (:), allocatable :: ngrwat real, dimension (:), allocatable :: filterw,sumix,usle_ls,phuacc @@ -479,6 +484,7 @@ module parm real, dimension (:), allocatable :: subp,sno_hru,hru_ra,wet_orgn real, dimension (:), allocatable :: tmx,tmn,rsdin,tmp_hi,tmp_lo real, dimension (:), allocatable :: rwt,olai,usle_k,tconc,hru_rmx + real, dimension (:), allocatable :: usle_cfac,usle_eifac real, dimension (:), allocatable :: anano3,aird,t_ov,sol_sumfc real, dimension (:), allocatable :: sol_avpor,usle_mult,wet_orgp real, dimension (:), allocatable :: aairr,cht,u10,rhd @@ -503,6 +509,8 @@ module parm real, dimension (:), allocatable :: wet_seci,pnd_no3g,pstsol real, dimension (:), allocatable :: gwht,delay,gw_q,pnd_solpg real, dimension (:), allocatable :: alpha_bf,alpha_bfe,gw_spyld + real, dimension (:), allocatable :: alpha_bf_d,alpha_bfe_d + real, dimension (:), allocatable :: gw_qdeep real, dimension (:), allocatable :: gw_delaye,gw_revap,rchrg_dp real, dimension (:), allocatable :: revapmn,anion_excl,rchrg real, dimension (:), allocatable :: ffc,bio_min,surqsolp @@ -512,7 +520,7 @@ module parm real, dimension (:), allocatable :: gwqmn,tdrain,pplnt,snotmp real, dimension (:), allocatable :: ddrain,gdrain,sol_crk,dayl,brt ! Drainmod tile equations 01/2006 - real, dimension (:), allocatable ::ddrain_hru,re,sdrain + real, dimension (:), allocatable ::ddrain_hru,re,sdrain,sstmaxd real, dimension (:), allocatable :: stmaxd,drain_co,pc,latksatf ! Drainmod tile equations 01/2006 real, dimension (:), allocatable :: twash,rnd2,rnd3,sol_cnsw,doxq @@ -567,8 +575,8 @@ module parm real, dimension (:,:), allocatable :: wushal,wudeep,tmnband,snoeb real, dimension (:,:), allocatable :: nsetlw,snotmpeb,bss,surf_bs real, dimension (:,:), allocatable :: tmxband,nsetlp - real, dimension (:,:), allocatable :: rainsub,hhsubp,frad - real, dimension (:), allocatable :: rhrbsb, rstpbsb + real, dimension (:,:), allocatable :: rainsub,frad + real, dimension (:), allocatable :: rstpbsb real, dimension (:,:), allocatable :: orig_snoeb,orig_pltpst real, dimension (:,:), allocatable :: terr_p, terr_cn, terr_sl real, dimension (:,:), allocatable :: drain_d, drain_t, drain_g @@ -580,7 +588,7 @@ module parm real, dimension (:,:,:), allocatable :: pst_lag, phug !! integer, dimension (:), allocatable :: ipot,nrelease,swtrg,hrupest integer, dimension (:), allocatable :: nrelease,swtrg,hrupest - integer, dimension (:), allocatable :: nro,nrot,nfert,npest + integer, dimension (:), allocatable :: nro,nrot,nfert integer, dimension (:), allocatable :: igro,nair,ipnd1,ipnd2 integer, dimension (:), allocatable :: nirr,iflod1,iflod2,ndtarg integer, dimension (:), allocatable :: iafrttyp, nstress @@ -623,7 +631,7 @@ module parm character(len=17), dimension (300) :: pname !! adding qtile to output.hru write 3/2/2010 gsm increased heds(70) to heds(71) !! increased hedr(42) to hedr(45) for output.rch gsm 10/17/2011 - character(len=13) :: heds(76),hedb(22),hedr(45),hedrsv(41) + character(len=13) :: heds(78),hedb(22),hedr(45),hedrsv(41) !! character(len=13) :: heds(73),hedb(21),hedr(42),hedrsv(41) character(len=13) :: hedwtr(40) ! character(len=4) :: title(60), cpnm(250) @@ -657,18 +665,13 @@ module parm real, dimension (:), allocatable :: hno2,hno3,horgp,hsolp,hbod real, dimension (:), allocatable :: hdisox,hchla,hsedyld,hsedst real, dimension (:), allocatable :: hharea,hsolpst,hsorpst - real, dimension (:), allocatable :: hhqday,hhprecip,precipdt + real, dimension (:), allocatable :: hhqday,precipdt real, dimension (:), allocatable :: hhtime,hbactp,hbactlp ! store initial values integer, dimension (:), allocatable :: ivar_orig real, dimension (:), allocatable :: rvar_orig ! Input Uncertainty, added by Ann van Griensven integer :: nauto, nsave, iatmodep -! integer, dimension (:), allocatable :: iseed - integer, dimension (:), allocatable :: itelmon, itelyr - real, dimension (:,:), allocatable :: variimon, variiyr - integer, dimension (:), allocatable :: itelmons, itelyrs - real, dimension (:,:), allocatable :: variimons, variiyrs ! additional reach variables , added by Ann van Griensven real, dimension (:), allocatable :: wattemp ! Modifications to Pesticide and Water routing routines by Balaji Narasimhan @@ -781,5 +784,100 @@ module parm & wtp_sdexp,wtp_sdc1,wtp_sdc2,wtp_sdc3,wtp_pdia,wtp_plen, & wtp_pmann,wtp_ploss,wtp_k,wtp_dp,wtp_sedi,wtp_sede,wtp_qi - real :: bio_init, lai_init, cnop,hi_ovr,harveff + real :: bio_init, lai_init, cnop,hi_ovr,harveff,frac_harvk + + +!! By Zhang for C/N cycling + !!SOM-residue C/N state variables -- currently included + real, dimension(:,:), allocatable :: sol_BMC, sol_BMN, sol_HSC, + & sol_HSN, sol_HPC, sol_HPN, sol_LM, + & sol_LMC, sol_LMN, sol_LS, sol_LSL, sol_LSC, sol_LSN , sol_RNMN, + & sol_LSLC, sol_LSLNC, sol_RSPC, sol_WOC, sol_WON, sol_HP, sol_HS, + & sol_BM + ! HSC mass of C present in slow humus (kg ha-1) + ! HSN mass of N present in slow humus (kg ha-1) + ! HPC mass of C present in passive humus (kg ha-1) + ! HPN mass of N present in passive humus (kg ha-1) + ! LM mass of metabolic litter (kg ha-1) + ! LMC mass of C in metabolic litter (kg ha-1) + ! LMN mass of N in metabolic litter (kg ha-1) + ! LS mass of structural litter (kg ha-1) + ! LSC mass of C in structural litter (kg ha-1) + ! LSL mass of lignin in structural litter (kg ha-1) + ! LSN mass of N in structural litter (kg ha-1) + + !!SOM-residue C/N state variables -- may need to be included + real, dimension(:,:), allocatable :: sol_CAC, sol_CEC + + !!daily updated soil layer associated percolaton and lateral flow Carbon loss + real, dimension(:,:), allocatable :: sol_percc + real, dimension(:,:), allocatable :: sol_latc + + !!Daily carbon change by different means (entire soil profile for each HRU) + real, dimension(:), allocatable :: sedc_d, surfqc_d, latc_d, + & percc_d, foc_d, NPPC_d, rsdc_d, grainc_d, stoverc_d, soc_d, + & rspc_d, emitc_d + !!emitc_d include biomass_c eaten by grazing, burnt + + + !!Daily carbon change by different means (entire soil profile for each Subbasin) + !!Only defined the variables, but not used them in the code + real, dimension(:), allocatable :: sub_sedc_d, sub_surfqc_d, + & sub_latc_d, sub_percc_d, sub_foc_d, sub_NPPC_d, sub_rsdc_d, + & sub_grainc_d, sub_stoverc_d, sub_emitc_d, sub_soc_d, sub_rspc_d + + + !!Monthly carbon change by different means (entire soil profile for each HRU) + real, dimension(:), allocatable :: sedc_m, surfqc_m, latc_m, percc_m, + & foc_m, NPPC_m, rsdc_m, grainc_m, stoverc_m, emitc_m, soc_m, + & rspc_m + + !!Yearly carbon change by different means (entire soil profile for each HRU) + real, dimension(:), allocatable :: sedc_a, surfqc_a, latc_a, + & percc_a, foc_a, NPPC_a, rsdc_a, grainc_a, stoverc_a, emitc_a, + & soc_a, rspc_a + + + !! The following variables are defined and calculated locally + !! ================================================================== + ! HSCTP potential transformation of C in slow humus (kg ha-1 day-1) + ! HSNTP potential transformation of N in slow humus (kg ha.1 day-1) + ! HPCTP potential transformation of C in passive humus (kg ha-1 day-1) + ! HPNTP potential transformation of N in passive humus (kg ha-1 day-1) + ! HPR rate of transformation of passive humus under optimal conditions (subsurface + ! layers = 0.000012 day-1) (Parton et al.,1993, 1994) + ! HSR rate of transformation of slow humus under optimal conditions (all layers + ! = 0.0005 day.1) (Parton et al., 1993, 1994; Vitousek et al., 1993) + ! KOC liquid C solid partition coefficient for microbial biomass (10^3 m3 Mg-1) + ! LMF fraction of the litter that is metabolic + ! LMNF fraction of metabolic litter that is N (kg kg-1) + ! LMR rate of transformation of metabolic litter under optimal conditions (surface = + ! 0.0405 day-1; all other layers = 0.0507 day-1) (Parton et al., 1994) + ! LMCTP potential transformation of C in metabolic litter (kg ha-1 day-1) + ! LMNTP potential transformation of N in metabolic litter (kg ha-1 day-1) + ! LSCTP potential transformation of C in structural litter (kg ha-1 day-1) + ! LSF fraction of the litter that is structural + ! LSLF fraction of structural litter that is lignin (kg kg-1) + ! LSNF fraction of structural litter that is N (kg kg-1) + ! LSLCTP potential transformation of C in lignin of structural litter (kg ha-1 day-1) + ! LSLNCTP potential transformation of C in nonlignin structural litter (kg ha-1 day-1) + ! LSNTP potential transformation of N in structural litter (kg ha-1 day-1) + ! LSR rate of potential transformation of structural litter under optimal conditions + ! (surface = 0.0107 day.1; all other layers = 0.0132 day.1) (Parton et al., 1994) + ! NCBM N/C ratio of biomass + ! NCHP N/C ratio passive humus + ! NCHS N/C ratio of the slow humus + ! OX oxygen control on biological processes with soil depth + ! Sf fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for belowground litter + + !!Tillage factor on SOM decomposition + integer, dimension(:), allocatable :: tillage_switch + real, dimension(:), allocatable :: tillage_depth + integer, dimension(:), allocatable :: tillage_days + real, dimension(:), allocatable :: tillage_factor + ! tillage_factor: = 1.6 in 30 days after tillage practices occur; otherwise 1.0; +!! By Zhang for C/N cycling + + + end module parm diff --git a/src/newtillmix.f b/src/newtillmix.f index eb23765..cca2321 100644 --- a/src/newtillmix.f +++ b/src/newtillmix.f @@ -130,8 +130,13 @@ subroutine newtillmix(jj,bmix) !$$$$$$ integer :: l, k, nl, a integer :: l, k !CB 12/2/09 nl and a are not used. real :: emix, dtil, XX, WW1, WW2, WW3, WW4, maxmix -!$$$$$$ real :: thtill(sol_nly(jj)), smix(20+npmx) - real :: smix(22+npmx) !CB 12/2/09 thtill is not used. mjw rev 490 +!$$$$$$ real :: thtill(sol_nly(jj)), smix(20+npmx) + !!by zhang + !!============= + real :: smix(22+npmx+12) !CB 12/2/09 thtill is not used. mjw rev 490 + !!changed the dimension from 22 + npmx to 22 + npmx + 12 + !!by zhang + !!============= real :: sol_mass(sol_nly(jj)) real :: sol_thick(sol_nly(jj)), sol_msm(sol_nly(jj)) real :: sol_msn(sol_nly(jj)) @@ -154,6 +159,19 @@ subroutine newtillmix(jj,bmix) dtil = deptil(idtill) end if + !!by zhang DSSAT tillage + !!======================= + !! deptil(:) |mm |depth of mixing caused by tillage operation + !jj is hru number + if (cswat == 2) then + tillage_days(jj) = 0 + tillage_depth(jj) = dtil + tillage_switch(jj) = 1 + end if + !!by zhang DSSAT tillage + !!======================= + + smix = 0. sol_mass = 0. sol_thick = 0. @@ -245,6 +263,26 @@ subroutine newtillmix(jj,bmix) do k = 1, npmx smix(20+k) = smix(20+k) + sol_pst(k,jj,l) * WW1 end do + + !!by zhang + !!============== + if (cswat == 2) then + smix(20+npmx+1) = smix(20+npmx+1) +sol_LSC(l,jj)* WW1 + smix(20+npmx+2) = smix(20+npmx+2) +sol_LSLC(l,jj)* WW1 + smix(20+npmx+3) = smix(20+npmx+3) +sol_LSLNC(l,jj)* WW1 + smix(20+npmx+4) = smix(20+npmx+4) +sol_LMC(l,jj)* WW1 + smix(20+npmx+5) = smix(20+npmx+5) +sol_LM(l,jj)* WW1 + smix(20+npmx+6) = smix(20+npmx+6) +sol_LSL(l,jj)* WW1 + smix(20+npmx+7) = smix(20+npmx+7) +sol_LS(l,jj)* WW1 + + smix(20+npmx+8) = smix(20+npmx+8) +sol_LSN(l,jj)* WW1 + smix(20+npmx+9) = smix(20+npmx+9) +sol_LMN(l,jj)* WW1 + smix(20+npmx+10) = smix(20+npmx+10) +sol_BMN(l,jj)* WW1 + smix(20+npmx+11) = smix(20+npmx+11) +sol_HSN(l,jj)* WW1 + smix(20+npmx+12) = smix(20+npmx+12) +sol_HPN(l,jj)* WW1 + end if + !!by zhang + !!============= XX = XX + sol_msm(l) end do @@ -293,6 +331,25 @@ subroutine newtillmix(jj,bmix) sol_pst(k,jj,l) = sol_pst(k,jj,l) * WW3 + smix(20+k) * WW4 end do + !!by zhang + !!============= + if (cswat == 2) then + sol_LSC(l,jj) = sol_LSC(l,jj)*WW3+smix(20+npmx+1)* WW4 + sol_LSLC(l,jj) = sol_LSLC(l,jj)*WW3+smix(20+npmx+2)* WW4 + sol_LSLNC(l,jj) = sol_LSLNC(l,jj)*WW3+smix(20+npmx+3)* WW4 + sol_LMC(l,jj) = sol_LMC(l,jj)*WW3 + smix(20+npmx+4)* WW4 + sol_LM(l,jj) = sol_LM(l,jj)*WW3 + smix(20+npmx+5)* WW4 + sol_LSL(l,jj) = sol_LSL(l,jj)*WW3 + smix(20+npmx+6)* WW4 + sol_LS(l,jj) = sol_LS(l,jj)*WW3 + smix(20+npmx+7)* WW4 + sol_LSN(l,jj) = sol_LSN(l,jj)*WW3 + smix(20+npmx+8)* WW4 + sol_LMN(l,jj) = sol_LMN(l,jj)*WW3 + smix(20+npmx+9)* WW4 + sol_BMN(l,jj) = sol_BMN(l,jj)*WW3 + smix(20+npmx+10)* WW4 + sol_HSN(l,jj) = sol_HSN(l,jj)*WW3 + smix(20+npmx+11)* WW4 + sol_HPN(l,jj) = sol_HPN(l,jj)*WW3 + smix(20+npmx+12)* WW4 + end if + !!by zhang + !!============== + end do if (cswat == 1) then diff --git a/src/nlch.f b/src/nlch.f index f92c068..ce968c2 100644 --- a/src/nlch.f +++ b/src/nlch.f @@ -132,7 +132,7 @@ subroutine nlch nloss = (2.18 * dis_stream(j) - 8.63) / 100. - nloss = Amax1(0.,nloss) + nloss = amax1(0.,nloss) nloss = Amin1(1.,nloss) latno3(j) = (1. - nloss) * latno3(j) diff --git a/src/nminrl.f b/src/nminrl.f index 04c4d28..befc235 100644 --- a/src/nminrl.f +++ b/src/nminrl.f @@ -192,7 +192,7 @@ subroutine nminrl !! change for domain error 1/29/09 gsm check with Jeff !!! if (sol_st(kk,j) < 0.) sol_st(kk,j) = .0000001 sut = .1 + .9 * Sqrt(sol_st(kk,j) / sol_fc(kk,j)) - sut = Min(1., sut) +! sut = Min(1., sut) sut = Max(.05, sut) !!compute soil temperature factor diff --git a/src/openwth.f b/src/openwth.f index da91b34..c1efbff 100644 --- a/src/openwth.f +++ b/src/openwth.f @@ -58,13 +58,13 @@ subroutine openwth kk2 = kk1 + (nrgfil - 1) end if if (rfile(j) /= ' ') then - open (100+j,file=rfile(j),recl=800) + !! open (100+j,file=rfile(j),recl=800) + open (100+j,file=rfile(j),recl=1850) read (100+j,5000) titldum read (100+j,5000) titldum read (100+j,5000) titldum if (ievent < 2) then !daily records read (100+j,5001) (elevp(k), k = kk1, kk2) - 5001 format (7x,1800i5) !!-----------------------------------------1800 precip gages test else !subdaily records read (100+j,5003) (elevp(k), k = kk1, kk2) endif @@ -82,7 +82,8 @@ subroutine openwth kk2 = kk1 + (ntgfil - 1) end if if (tfile(j) /= ' ') then - open (118+j,file=tfile(j),recl=800) + !! open (118+j,file=tfile(j),recl=800) + open (118+j,file=tfile(j),recl=20000) read (118+j,5000) titldum read (118+j,5000) titldum read (118+j,5000) titldum @@ -91,17 +92,20 @@ subroutine openwth end do if (slrfile /= ' ') then - open (137,file=slrfile,recl=800) + !! open (137,file=slrfile,recl=800) + open (137,file=slrfile,recl=15000) read (137,5000) titldum end if if (rhfile /= ' ') then - open (138,file=rhfile,recl=800) + !! open (138,file=rhfile,recl=800) + open (138,file=rhfile,recl=15000) read (138,5000) titldum end if if (wndfile /= ' ') then - open (139,file=wndfile,recl=800) + !! open (139,file=wndfile,recl=800) + open (139,file=wndfile,recl=15000) read (139,5000) titldum end if @@ -112,7 +116,8 @@ subroutine openwth return 5000 format (a80) -! 5001 format (7x,300i5) !!-----------------------------------commented for test raingage 1800 - 5002 format (7x,287i10) - 5003 format (12x,300i5) + 5001 format (7x,1800i5) + 5002 format (7x,1800i10) +! 5002 format (7x,287i10) + 5003 format (12x,1800i5) end diff --git a/src/ovr_sed.f b/src/ovr_sed.f index ccf80a4..8d98518 100644 --- a/src/ovr_sed.f +++ b/src/ovr_sed.f @@ -168,7 +168,7 @@ subroutine ovr_sed() bed_shear = 9807 * (hhqday(k) / 1000.) * hru_slp(j) ! N/m2 sedov = 11.02 * rill_mult * usle_k(j) * c_factor * c * & bed_shear ** eros_expo ! kg/hour/m2 - if(ievent>2) then + if(ievent>=2) then sedov = 16.667 * sedov * hru_km(j) * idt ! tons per time step else sedov = 24000. * sedov * hru_km(j) ! tons per day diff --git a/src/percmain.f b/src/percmain.f index 57fa48e..c35df07 100644 --- a/src/percmain.f +++ b/src/percmain.f @@ -21,7 +21,11 @@ subroutine percmain !! |0 simulate tile flow using subroutine origtile(wt_shall,d) !! iwtdn |none |water table depth algorithms flag/code !! |1 simulate wt_shall using subroutine new water table depth routine -!! |0 simulate wt_shall using subroutine original water table depth routine +!! |0 simulate wt_shall using subroutine original water table depth routine +!! ismax |none |maximum depressional storage selection flag/code +!! |1 dynamic stmaxd computed as a function of random roughness and rain intensity +!! |by depstor.f +!! |0 static stmaxd read from .bsn for the global value or .sdr for specific hrus !! drainmod tile equations 01/2006 !! sol_fc(:,:) |mm H2O |amount of water available to plants in soil !! |layer at field capacity (fc - wp) @@ -103,7 +107,9 @@ subroutine percmain if (aird(j)>0) then j=j end if - sepday = inflpcp + aird(j) + sepday = inflpcp + aird(j) + pot_seep(j) + pot_seep(j) = 0. + !! if unlimted, or groundwater source reset aird here (otherwise in virtual) !! change per JGA 10/12/11 irrigation problem with reach !! if (irrsc(j) > 2) aird(j) = 0. diff --git a/src/pgenhr.f b/src/pgenhr.f index e535801..0118d22 100644 --- a/src/pgenhr.f +++ b/src/pgenhr.f @@ -23,8 +23,6 @@ subroutine pgenhr(jj) !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! hhsubp(:,:) |mm H2O |precipitation falling during hour in day in -!! |HRU !! rainsub(:) |mm H2O |rainfall during time step !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ @@ -170,17 +168,6 @@ subroutine pgenhr(jj) rainsub(jj,itime) = subp(jj) - sumrain end if - itime = 1 - nhour = 0 - nhour = nstep / 24 - do ihour = 1, 24 - do k = 1, nhour - hhsubp(jj,ihour) = hhsubp(jj,ihour) + rainsub(jj,itime) - itime = itime + 1 - end do - end do - - return end diff --git a/src/pmeas.f b/src/pmeas.f index abb0004..717fc36 100644 --- a/src/pmeas.f +++ b/src/pmeas.f @@ -37,8 +37,6 @@ subroutine pmeas !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! hhsubp(:,:) |mm H2O |precipitation falling during hour in day in -!! |HRU !! ifirstpcp(:)|none |precipitation data search code !! |0 first day of precipitation data located in !! | file @@ -127,8 +125,6 @@ subroutine pmeas iyp = 0 idap = 0 read (100+k,5100) iyp, idap, (rmeas(l), l = kk1, kk2) -5000 format (7x,1800f5.1) -5100 format (i4,i3,1800f5.1) if (iyp + idap <= 0) exit if (iyp == iyr .and. idap == id1) exit end do @@ -146,9 +142,6 @@ subroutine pmeas if (hru_sub(k) == inum3sprev .and. hru_sub(k) /= 0) then subp(k) = rbsb if (ievent == 1) then - do l = 1, 24 - hhsubp(k,l) = rhrbsb(l) - end do do l = 1, nstep rainsub(k,l) = rstpbsb(l) end do @@ -161,11 +154,7 @@ subroutine pmeas inum3sprev = hru_sub(k) rbsb = subp(k) if (ievent == 1) then - rhrbsb(:) = 0. rstpbsb(:) = 0. - do l = 1, 24 - rhrbsb(l) = hhsubp(k,l) - end do do l = 1, nstep rstpbsb(l) = rainsub(k,l) end do @@ -303,8 +292,8 @@ subroutine pmeas return -! 5000 format (7x,300f5.1) !! -------------------------------test -! 5100 format (i4,i3,300f5.1) !! -------------------------------test + 5000 format (7x,1800f5.1) + 5100 format (i4,i3,1800f5.1) 5200 format (i4,i3,i2,1x,i2,300f6.2) 5201 format (i4,i3,5x,300f5.1) 5202 format (i4,i3,i2,a1,i2,300f6.2) diff --git a/src/pminrl2.f b/src/pminrl2.f index bbbafc2..3bdacea 100644 --- a/src/pminrl2.f +++ b/src/pminrl2.f @@ -73,7 +73,7 @@ subroutine pminrl2 !! vara |Intermediate Variable !! varb |Intermediate Variable !! varc |Intermediate Variable -!! arate |Intermediate Variable | +!! arate |Intermediate Variable | !! j |none |HRU number !! l |none |counter (soil layer) !! rmn1 |kg P/ha |amount of phosphorus moving from the solution @@ -93,7 +93,7 @@ subroutine pminrl2 use parm integer :: j, l real :: rto, rmn1, roc, wetness, base vara,varb,varc,as_p_coeff - real*8 solp(10),actp(10),stap(10) !! locals for concentation based data + real*8 solp(mlyr),actp(mlyr),stap(mlyr) !! locals for concentation based data j = 0 j = ihru diff --git a/src/pothole.f b/src/pothole.f index 52858a5..78bdd8b 100644 --- a/src/pothole.f +++ b/src/pothole.f @@ -166,7 +166,7 @@ subroutine pothole real, parameter :: pi = 3.1416 integer :: j, ly - real :: potsep, sumo, potev, cnv, potpcp, no3in + real :: potsep, sumo, potev, cnv, potpcp, no3in, qdayi real :: sedloss, no3loss, yy, dg, excess, stmax, sedsetl real :: sanloss, silloss, claloss, sagloss, lagloss real :: potmm,minpsloss,minpaloss, solploss, orgnloss, orgploss @@ -184,6 +184,7 @@ subroutine pothole potevmm = 0. potsepmm = 0. potflwo = 0. + potflwosp = 0. potsedo = 0. potsano = 0. potsilo = 0. @@ -196,9 +197,15 @@ subroutine pothole potorgpo = 0. potmpso = 0. potmpao = 0. - - qin = qdr(j) !inflow = water yield (surf+lat+gw) - no3in = surqno3(j) + latno3(j) ! + gwno3(j) - don't include groundwater no3 + potvol_ini = 0. + potsa_ini = 0. + + qin = qday * pot_fr(j) !inflow = surface flow + qdayi = qday + qday = qday * (1. - pot_fr(j)) + potloss = qdayi - qday + qdr(j) = qdr(j) - potloss + no3in = surqno3(j) !+ latno3(j) + gwno3(j) - don't include groundwater no3 !! conversion factors cnv = 10. * hru_ha(j) @@ -206,9 +213,16 @@ subroutine pothole ! when water is impounding if (imp_trig(j) == 1) return + +! update volume of water in pothole +! pot_fr is now the fraction of the hru draining into the pothole +! the remainder (1-pot_fr) goes directly to runoff + pot_vol(j) = pot_vol(j) + qin + potflwi(j) = potflwi(j) + qin ! compute surface area assuming a cone shape (m^2) - potsa(j) = pi * (3. * pot_vol(j) / (pi * hru_slp(j)))**.6666 + potvol_m3 = pot_vol(j) * cnv + potsa(j) = pi * (3. * potvol_m3 / (pi * hru_slp(j)))**.6666 potsa(j) = potsa(j) / 10000. !convert to ha if (potsa(j) <= 0.000001) then potsa(j) = 0.001 @@ -216,14 +230,9 @@ subroutine pothole if (potsa(j) > hru_ha(j)) then potsa(j) = hru_ha(j) endif + potvol_ini = pot_vol(j) + potsa_ini = potsa(j) -! update volume of water in pothole -! pot_fr is now the fraction of the hru draining into the pothole -! the remainder (1-pot_fr) goes directly to runoff - pot_vol(j) = pot_vol(j) + qin * pot_fr(j) * cnv - potflwi(j) = potflwi(j) + qin * pot_fr(j) * cnv - qdr(j) = qdr(j) * (1. - pot_fr(j)) - ! update sediment in pothole pot_sed(j) = pot_sed(j) + sedyld(j) * pot_fr(j) potsedi(j) = pot_sed(j) @@ -275,11 +284,12 @@ subroutine pothole sedminpa(j) = sedminpa (j) * yy ! if overflow, then send the overflow to the HRU surface flow - if (pot_vol(j) > pot_volx(j)) then - qdr(j) = qdr(j) + (pot_vol(j)- pot_volx(j)) / cnv - spillo = pot_vol(j)- pot_volx(j) - pot_vol(j) = pot_volx(j) - xx = spillo / (spillo + pot_volx(j)) + if (pot_vol(j) > pot_volxmm(j)) then + qdr(j) = qdr(j) + (pot_vol(j)- pot_volxmm(j)) +! qday = qday + (pot_vol(j)- pot_volxmm(j)) + spillo = pot_vol(j)- pot_volxmm(j) + pot_vol(j) = pot_volxmm(j) + xx = spillo / (spillo + pot_volxmm(j)) potsedo = potsedo + pot_sed(j) * xx potsano = potsano + pot_san(j) * xx potsilo = potsilo + pot_sil(j) * xx @@ -314,12 +324,12 @@ subroutine pothole pot_sag(j) = sagyld(j) + potsago lagyld(j) = lagyld(j) + potlago - surqno3(j) = surqno3(j) + potno3o / cnv - surqsolp(j) = surqsolp(j) + potsolpo / cnv - sedorgn(j) = sedorgn(j) + potorgno / cnv - sedorgp(j) = sedorgp(j) + potorgpo / cnv - sedminps(j) = sedminps(j) + potmpso / cnv - sedminpa(j) = sedminpa(j) + potmpao / cnv + surqno3(j) = surqno3(j) + potno3o + surqsolp(j) = surqsolp(j) + potsolpo + sedorgn(j) = sedorgn(j) + potorgno + sedorgp(j) = sedorgp(j) + potorgpo + sedminps(j) = sedminps(j) + potmpso + sedminpa(j) = sedminpa(j) + potmpao end if !! if overflow ! If no overflow, compute settling and losses, surface inlet tile @@ -359,48 +369,64 @@ subroutine pothole pot_mpa(j) = .75 * drcla * pot_mpa(j) pot_no3(j) = pot_no3(j) * (1. - pot_no3l(j)) - pot_solp(j) = pot_solp(j) * (1. - pot_no3l(j)) + pot_solp(j) = pot_solp(j) * (1. - pot_solpl(j)) ! hlife_pot = 20. !!assume half life of 20 days ! pot_no3(j) = Exp(-.693 / hlife_pot) * pot_no3(j) ! pot_solp(j) = Exp(-.693 / hlife_pot) * pot_solp(j) +! compute flow from surface inlet tile + tileo = Min(pot_tilemm(j), pot_vol(j)) + pot_vol(j) = pot_vol(j) - tileo + qdr(j) = qdr(j) + tileo + tileq(j) = tileq(j) + tileo + sumo = sumo + tileo + tile_out(j) = tile_out(j) + tileo + ! limit seepage into soil if profile is near field capacity - yy = 0. - if (sol_sw(j) / sol_sumfc(j) < .5) then - yy = 1. - elseif (sol_sw(j) / sol_sumfc(j) < 1.) then - yy = 1. - sol_sw(j) / sol_sumfc(j) - end if - + if (pot_k(j) > 0.) then + yy = pot_k(j) + else + yy = sol_k(1,j) + endif + ! calculate seepage into soil - potsep = yy * sol_k(1,j) * potsa(j) * 240. + potsep = yy * potsa(j) * 240. / cnv !!mm/h*ha/240=m3/cnv=mm potsep = Min(potsep, pot_vol(j)) pot_vol(j) = pot_vol(j) - potsep - pot_seep(j)= pot_seep(j)+ potsep + pot_seep(j) = potsep + +! call percmain +! sol_st(1,j) = sol_st(1,j) + potsep +!! redistribute water so that no layer exceeds maximum storage +! excess = sol_st(ly,j) - sol_fc(ly,j) +! do ly = 1, sol_nly(j) +! if (excess < 0.) exit +! if (ly < sol_nly(j)) then +! sol_st(ly+1,j) = sol_st(ly+1,j) + excess +! excess = sol_st(ly+1,j) - sol_fc(ly+1,j) +! sol_st(ly,j) = sol_fc(ly,j) +! else +! sol_st(ly,j) = sol_fc(ly,j) +! end if +! end do +! excess = Max(0.,excess) +! +! if (excess > 1.e-9) then +! do ly = 1, sol_nly(j) +! excess = sol_st(ly,j) - sol_ul(ly,j) +! if (excess < 0.) exit +! if (ly < sol_nly(j)) then +! sol_st(ly+1,j) = sol_st(ly+1,j) + excess +! sol_st(ly,j) = sol_ul(ly,j) +! else +! sol_st(ly,j) = sol_ul(ly,j) +! pot_vol(j) = pot_vol(j) + excess +! potsep = potsep - excess +! end if +! end do +! pot_seep(j) = pot_seep(j) + potsep +! end if - - sol_st(1,j) = sol_st(1,j) + potsep / hru_ha(j) / 10. - - -! redistribute water so that no layer exceeds maximum storage - do ly = 1, sol_nly(j) - dg = 0. - stmax = 0. - excess = 0. - if (ly == 1) then - dg = sol_z(ly,j) - else - dg = sol_z(ly,j) - sol_z(ly-1,j) - end if - stmax = sol_por(ly,j) * dg - if (sol_st(ly,j) <= stmax) exit - excess = sol_st(ly,j) - stmax - sol_st(ly,j) = stmax - if (ly + 1 <= sol_nly(j)) then - sol_st(ly+1,j) = sol_st(ly+1,j) + excess - end if - end do - ! recompute total soil water sol_sw(j) = 0. do ly = 1, sol_nly(j) @@ -410,22 +436,12 @@ subroutine pothole ! compute evaporation from water surface if (laiday(j) < evlai) then potev = (1. - laiday(j) / evlai) * pet_day - potev = 10. * potev * potsa(j) !!units mm => m^3 potev = Min(potev, pot_vol(j)) pot_vol(j) = pot_vol(j) - potev pot_evap(j)= pot_evap(j) + potev endif -!!!! output.pot and output.wtr turned on by same code named IWTR in file.cio - if (iwtr == 1) then - write (125,2000)i,j,pot_vol(j),potsa(j),spillo,potsep,potev, & - & sol_sw(j), subnum(j), hruno(j) - endif - 2000 format (2i4,6f10.2,1x,a5,a4) - if (pot_vol(j) > 1.e-6) then -! compute flow from surface inlet tile - tileo = Min(pot_tile(j), pot_vol(j)) - sumo = sumo + tileo - tile_out(j) = tile_out(j) + tileo + + if (pot_vol(j) > 1.e-6) then sedloss = pot_sed(j) * tileo / pot_vol(j) sedloss = Min(sedloss, pot_sed(j)) @@ -497,39 +513,47 @@ subroutine pothole tile_orgpo(j)= tile_orgpo(j)+ orgploss tile_minpso(j)= tile_minpso(j)+ minpsloss tile_minpao(j)= tile_minpao(j)+ minpaloss - - if (pot_vol(j) > 0. .and. potsa(j) > 0.0) then - potpcpmm = precipday - potevmm = potev / hru_ha(j) / 10. !!NUBZ - potsepmm = potsep / hru_ha(j) / 10. !!NUBZ - potflwo = sumo / hru_ha(j) / 10. !!NUBZ - endif - - pot_vol(j) = pot_vol(j) - tileo - qdr(j) = qdr(j) + tileo / cnv end if + endif - ! if urban bmp - set maximum concentrations ! xx = sed_con(j) + soln_con(j) + solp_con(j) + orgn_con(j) & ! & + orgp_con(j) ! if (xx > 1.e-6) then ! call urb_bmp ! end if - -! summary calculations - if (curyr > nyskip) then - potmm = 0. - if (pot_vol(j) > 0. .and. potsa(j) > 0.0) then + +! summary calculations + if (curyr > nyskip) then + potmm = 0. + if (pot_vol(j) > 0. .and. potsa(j) > 0.0) then potmm = pot_vol(j) / potsa(j) / 10. endif - spadyo = spadyo + potflwo * hru_dafr(j) - spadyev = spadyev + potevmm * hru_dafr(j) - spadysp = spadysp + potsepmm * hru_dafr(j) - spadyrfv = spadyrfv + potpcpmm * hru_dafr(j) + spadyo = spadyo + sumo * hru_dafr(j) + spadyosp = spadyosp + spillo * hru_dafr(j) + spadyev = spadyev + potev * hru_dafr(j) + spadysp = spadysp + potsep * hru_dafr(j) + spadyrfv = spadyrfv + precipday * hru_dafr(j) end if + potvol_m3 = pot_vol(j) * cnv + potsa(j) = pi * (3. * potvol_m3 / (pi * hru_slp(j)))**.6666 + potsa(j) = potsa(j) / 10000. !convert to ha + if (potsa(j) <= 0.000001) then + potsa(j) = 0.001 + endif + if (potsa(j) > hru_ha(j)) then + potsa(j) = hru_ha(j) + endif +! !!! output.pot and output.wtr turned on by same code named IWTR in file.cio + if (iwtr == 1) then + write (125,2000) hruno(j), subnum(j), i, iyr, potvol_ini, & + & potsa_ini, spillo, potsep, potev, sol_sw(j), tileo, & + & pot_vol(j), potsa(j) + endif + 2000 format (a5,1x,a4,2i5,9f10.2) + return 1000 format (1x,i4,2x,9(f8.2,2x)) end diff --git a/src/print_hyd.f b/src/print_hyd.f index dcb543e..8b42ee4 100644 --- a/src/print_hyd.f +++ b/src/print_hyd.f @@ -26,10 +26,10 @@ subroutine print_hyd !! mauro/jerry whittaker hourly output file if (iphr > 0) then - do ij = 1, 24 + do ij = 1, nstep write (83,1000) iyr,i,ij,ihout,hhvaroute(2,ihout,ij) end do - 1000 format (4i6,1x,f10.3) + 1000 format (4i6,1x,e10.5) end if !! end hourly codes diff --git a/src/psed.f b/src/psed.f index a7eec76..aa9e6b0 100644 --- a/src/psed.f +++ b/src/psed.f @@ -108,8 +108,8 @@ subroutine psed(iwave) !! sum for subbasin sediment calculations sub_orgp(sb) = sub_orgp(sb) + (sol_orgp(1,j) + sol_fop(1,j) & + sol_mp(1,j)) * hru_dafr(j) - sub_minpa(sb) = sub_minpa(sb) + sol_actp(1,j) * hru_dafr(j) - sub_minps(sb) = sub_minps(sb) + sol_stap(1,j) * hru_dafr(j) + sub_minpa(sb) = sub_minpa(sb) + sol_actp(1,j) * hru_fr(j) + sub_minps(sb) = sub_minps(sb) + sol_stap(1,j) * hru_fr(j) else !! subbasin sediment calculations xx = sub_orgp(iwave) + sub_minpa(iwave) + sub_minps(iwave) diff --git a/src/reachout.f b/src/reachout.f index 01dbd4c..be33e2e 100644 --- a/src/reachout.f +++ b/src/reachout.f @@ -247,7 +247,7 @@ subroutine reachout varoute(16,ihout) = rch_cbod(jrch) * rtwtr/ 1000. varoute(17,ihout) = rch_dox(jrch) * rtwtr/ 1000. else - do ii = 1, 24 + do ii = 1, nstep hhvaroute(1,ihout,ii) = 0. hhvaroute(2,ihout,ii) = hrtwtr(ii) hhvaroute(3,ihout,ii) = hsedyld(ii) diff --git a/src/readbsn.f b/src/readbsn.f index 3716578..022f83a 100644 --- a/src/readbsn.f +++ b/src/readbsn.f @@ -104,7 +104,11 @@ subroutine readbsn !! |0 simulate tile flow using subroutine origtile(wt_shall,d) !! iwtdn |none |water table depth algorithms flag/code !! |1 simulate wt_shall using subroutine new water table depth routine -!! |0 simulate wt_shall using subroutine original water table depth routine +!! |0 simulate wt_shall using subroutine original water table depth routine +!! ismax |none |maximum depressional storage selection flag/code +!! |1 dynamic stmaxd computed as a function of random roughness and rain intensity +!! |by depstor.f +!! |0 static stmaxd read from .bsn for the global value or .sdr for specific hrus !! drainmod tile equations 01/2006 !! iwq |none |stream water quality code !! |0 do not model stream water quality @@ -193,7 +197,8 @@ subroutine readbsn !! |Mean air temperature at which precipitation !! |is equally likely to be rain as snow/freezing !! |rain. -!! sdrain_bsn |mm |Distance bewtween two drain or tile tubes (range 7600.0 - 30000.0) +!! sdrain_bsn |mm |Distance bewtween two drain or tile tubes (range 7600.0 - 30000.0) +!! sstmaxd(:) |mm |static maximum depressional storage; read from .sdr !! smfmn |mm/deg C/day |Minimum melt rate for snow during year (Dec. !! |21) where deg C refers to the air temperature. !! smfmx |mm/deg C/day |Maximum melt rate for snow during year (June @@ -487,7 +492,7 @@ subroutine readbsn if (eof < 0) exit read (103,*,iostat=eof) res_stlr_co if (eof < 0) exit -!!!!! following reads moved to end of .bsn file +! following reads moved to end of .bsn file ! read (103,*,iostat=eof) sol_p_model !! if = 1 use new soil P model ! if (eof < 0) exit read (103,*,iostat=eof) bf_flg @@ -509,7 +514,7 @@ subroutine readbsn read (103,*) (lu_nodrain(kk), kk=1,numlu) - !! subdaily erosion modeling by Jaehak Jeong + !! subdaily erosion modeling by Jaehak Jeong read (103,*,iostat=eof) titldum if (eof < 0) exit read (103,*,iostat=eof) eros_spl @@ -526,14 +531,14 @@ subroutine readbsn if (eof < 0) exit read (103,*,iostat=eof) sig_g if (eof < 0) exit -!! Drainmod input variables - 01/2006 +!! Drainmod input variables - 01/2006 read (103,*,iostat=eof) re_bsn if (eof < 0) exit read (103,*,iostat=eof) sdrain_bsn if (eof < 0) exit read (103,*,iostat=eof) drain_co_bsn if (eof < 0) exit -!! Drainmod input variables - 01/2006 +!! Drainmod input variables - 01/2006 read (103,*,iostat=eof) pc_bsn if (eof < 0) exit read (103,*,iostat=eof) latksatf_bsn @@ -546,12 +551,17 @@ subroutine readbsn if (eof < 0) exit read (103,*,iostat=eof) iabstr if (eof < 0) exit -! iatmodep = 0 - average annual -! = 1 - monthly +! iatmodep = 0 - average annual = 1 - monthly read (103,*,iostat=eof) iatmodep - if (eof < 0) exit + if (eof < 0) exit + read (103,*,iostat=eof) r2adj + if (eof < 0) exit + read (103,*,iostat=eof) sstmaxd_bsn + if (eof < 0) exit + read (103,*,iostat=eof) ismax + if (eof < 0) exit exit -!! Drainmod input variables - 01/2006 +!! Drainmod input variables - 01/2006 end do !! copy global values to local HRUs @@ -595,7 +605,7 @@ subroutine readbsn if (evlai <= 0.) evlai = 3.0 if (cncoef <= 0.) cncoef = 1.0 if (cdn <= 0.) cdn = 1.4 - if (sdnco <= 0.) sdnco = 1.10 + if (sdnco <= 0.) sdnco = 1.30 if (bactmx <= 0.) bactmx = 10. if (bactminlp <= 0.) bactminlp = .0 if (bactminp <= 0.) bactminp = 0. @@ -670,7 +680,40 @@ subroutine readbsn close (103) + !!add by zhang + !!===================== + if (cswat == 2) then + open (98,file="cswat_profile.txt",recl=356) + write (98,5102) 'year','day','lay','hru', + &'sol_mass','sol_cmass','sol_nmass','sol_LS', + &'sol_LM','sol_LSC','sol_LMC','sol_HSC', + &'sol_HPC','sol_BMC','sol_LSN','sol_LMN', + &'sol_HPN','sol_HSN','sol_BMN','sol_no3', + &'sol_fop','sol_orgp','sol_actp','sol_stap', + &'sol_solp' + + open (100,file="cswat_daily.txt",recl=786) + write (100,5104) 'year','day','hru','rsdc','sedc', + &'percc','latc','emitc','grainc','surfq_c', + &'stoverc','NPPC','foc','rspc','tot_mass','tot_cmass','tot_nmass', + &'tot_LSC','tot_LMC','tot_HSC','tot_HPC','tot_BMC','Biom_C','rwtf', + &'tot_no3_nh3','wdntl', + &'ET','Tillfactor','SW1','SW2','SW3','SW4','SW5','SW6','SW7','SW8', + &'SW9','SW10','SW11', + &'WFSC1','WFSC2','WFSC3','WFSC4','WFSC5','WFSC6','WFSC7','WFSC8', + &'WFSC9','WFSC10','WFSC11' + endif + !!add by zhang + !!===================== + +! open (111, file="final_n_balance.txt") +! open (112, file="final_yields.txt") + !! carbon output ends + + return 1000 format (a) 1001 format (i4) + 5102 format (3a5,30a15) + 5104 format (a4,a4,a8,48a16) end diff --git a/src/readfig.f b/src/readfig.f index f52d248..95a7d1e 100644 --- a/src/readfig.f +++ b/src/readfig.f @@ -119,6 +119,10 @@ subroutine readfig character (len=13) :: subfile, auto_in , rufile integer :: ii, eof + character (len=3), dimension (mhyd) :: char6, char7, char8 + char6 = " " + char7 = " " + char8 = " " !! initialize variables mhyd_bsn = 0 @@ -140,13 +144,45 @@ subroutine readfig else read (102,5000) a, icodes(idum), ihouts(idum), inum1s(idum), & & inum2s(idum), inum3s(idum), rnum1s(idum), inum4s(idum), & - & inum5s(idum) -! write (*,5000) a, icodes(idum), ihouts(idum), inum1s(idum), & -! & inum2s(idum), inum3s(idum), rnum1s(idum), inum4s(idum), & -! & inum5s(idum) + !! & inum5s(idum), inum6s(idum), inum7s(idum), inum8s(idum) + & inum5s(idum), char6(idum), char7(idum), char8(idum) end if - mhyd_bsn = mhyd_bsn + 1 - + mhyd_bsn = mhyd_bsn + 1 + +!!!!!! inum6s, inum7s and inum8s (integer) read in as char6, char7, char8 (character) and +!!!!!! converted back to integer due to "Subbasin:" included in the .fig file by ArcSWAT + jjii = 1 !! inum6s/inum7s + iijj = 0 !! inum8s + + ! if (char6(idum) == "Sub") inum6s = 0 + ! if (char7(idum) == "bas") inum7s = 0 + ! if (char8(idum) == "in:") inum8s = 0 + + if (char6(idum) == " 1") then + xyz = 0. + write (char6(idum), fmt=' (i3)') jjii + inum6s(idum) = jjii + else + inum6s(idum) = 0 + end if + + if (char7(idum) == " 1") then + xyz = 0. + write (char7(idum), fmt=' (i3)') jjii + inum7s(idum) = jjii + else + inum7s(idum) = 0 + end if + + if (char8(idum) == " 0") then + xyz = 0. + write (char8(idum), fmt=' (i3)') iijj + inum8s(idum) = iijj + else + inum8s(idum) = 1 + end if +!!!!!! end convert code + select case(icodes(idum)) case (0) !! icode = 0 FINISH command @@ -309,71 +345,60 @@ subroutine readfig end if case (17) !! icode = 17 ROUTING UNIT command - rutot = rutot + 1 rufile = "" read (102,5100) rufile call caps(rufile) iru = inum1s(idum) - daru_km(inum1s(idum)) = rnum1s(idum) + isub = inum2s(idum) +!! daru_km(isub,iru) = rnum1s(idum) open (113,file=rufile) call readru close(113) case (18) !! icode = 18 LANDSCAPE ROUTING command - if (rnum1s(idum) < 1.e-9) rnum1s(idum) = 1. + !!if (rnum1s(idum) < 1.e-9) rnum1s(idum) = 1. end select !! calculate upstream drainage area (km2) and impervious cover (km2) !! in the drainage arae at each subbasin outlet - if (icodes(idum)==1) then !subbasin + if (icodes(idum)==1) then !subbasin subdr_km(ihouts(idum)) = sub_km(inum1s(idum)) - elseif (icodes(idum)==5) then !add + elseif (icodes(idum)==17) then !routing unit + subdr_km(ihouts(idum)) = daru_km(inum2s(idum),inum1s(idum)) + elseif (icodes(idum)==5) then !add subdr_km(ihouts(idum)) = subdr_km(inum1s(idum)) & + subdr_km(inum2s(idum)) subdr_ickm(ihouts(idum)) = subdr_ickm(inum1s(idum)) & + subdr_ickm(inum2s(idum)) elseif (icodes(idum)==2) then !route + if(inum1s(idum)==inum2s(idum)) then + subdr_km(ihouts(idum)) = subdr_km(inum1s(idum)) + subdr_ickm(ihouts(idum)) = subdr_ickm(inum1s(idum)) + else + subdr_km(ihouts(idum)) = subdr_km(inum1s(idum)) + & + subdr_km(inum2s(idum)) + subdr_ickm(ihouts(idum)) = subdr_ickm(inum1s(idum)) + & + subdr_ickm(inum2s(idum)) + endif + elseif (icodes(idum)==18) then !routels subdr_km(ihouts(idum)) = subdr_km(inum2s(idum)) - subdr_km(inum1s(idum)) = subdr_km(inum2s(idum)) - subdr_ickm(ihouts(idum)) = subdr_ickm(inum2s(idum)) - subdr_ickm(inum1s(idum)) = subdr_ickm(inum2s(idum)) + ru_a(inum3s(idum),inum1s(idum)) = subdr_km(ihouts(idum)) * & +! & daru_km(inum3s(idum),inum1s(idum))) / & + & 100. / ru_ovsl(inum3s(idum),inum1s(idum)) end if end if end do - if (isproj == 2) then -! ch_erod = .015 - ch_cov2 = 0.50 - flocnst = 0.5 * flocnst - sedcnst= 0.5 * sedcnst - orgncnst = 0.5 * 0.5 * orgncnst - orgpcnst = 0.5 * orgpcnst - no3cnst = 0.5 * 1.5 * no3cnst - nh3cnst = 0.5 * nh3cnst - no2cnst = 0.5 * no2cnst - minpcnst = 0.5 * minpcnst - cbodcnst = 0.5 * cbodcnst - disoxcnst = 0.5 * disoxcnst - chlacnst = 0.5 * chlacnst - solpstcnst = 0.5 * solpstcnst - srbpstcnst = 0.5 * srbpstcnst - bactpcnst = 0.5 * bactpcnst - bactlpcnst = 0.5 * bactlpcnst -! cmt11cnst = 0.5 * cmt11cnst -! cmt12cnst = 0.5 * cmt12cnst -! cmt13cnst = 0.5 * cmt13cnst - end if - - !! close .fig file close (102) return !! isproj = 0 - 5000 format (a1,9x,5i6,f6.3,i9,i3) +!! 5000 format (a1,9x,5i6,f6.3,i9,4i3) + 5000 format (a1,9x,5i6,f6.3,i9,i3,3a3) 5001 format (7x,i3,4x,6f12.3) 5002 format(a) 5004 format (10x,3i4) diff --git a/src/readfile.f b/src/readfile.f index 81c9573..f9ec8cc 100644 --- a/src/readfile.f +++ b/src/readfile.f @@ -602,7 +602,7 @@ subroutine readfile open (24,file="input.std") open (26,file="output.std") - open (28,file="output.hru",recl=1000) + open (28,file="output.hru",recl=1500) if (ia_b == 1) then open (33333,file="outputb.hru",form='unformatted') end if @@ -724,9 +724,11 @@ subroutine readfile write (125, 1000) end if - 1000 format (1x,'DAY',t6,'HRU',t12,'POT_VOL',t24,'POTSA',t33,'SPILLO', & - &t43,'POTSEP',t54,'POTEV',t63,'SOL_SW',t73,'GISnum'/,t14,'(m3)', & - &t24,'(ha)',t34,'(m3)',t44,'(m3)',t55,'(m3)',t64,'(m3)') + 1000 format (1x,'HRU',t6,'SUB',t12,'DAY',t17,'YEAR',t26,'VOL-I',t37, & + &'SA-I',t46,'SPILLO', + &t56,'POTSEP',t66,'POTEV',t75,'SOL_SW',t85,'TILE-O',t96,'VOL-F', & + &t106,'SA-F',/,t27,'(mm)',t37,'(ha)',t47,'(mm)',t57,'(mm)',t67, & + &'(mm)',t77,'(mm)',t87,'(mm)',t97,'(mm)',t107,'(ha)') ! code for writing out calendar day or julian day to output.rch, .sub, .hru files ! icalen = 0 (print julian day) 1 (print month/day/year) @@ -761,13 +763,13 @@ subroutine readfile !! sj september 2010 CSWAT final output + if (cswat == 1) then open (100,file="cswat_profile.txt",recl=280) write (100,*) 'year',';','day',';','hru',';','cmass',';','sol_rsd', &';','mancmass' + end if -! open (111, file="final_n_balance.txt") -! open (112, file="final_yields.txt") - !! carbon output ends + !! septic result J.Jeong Feb2009 open (173,file='septic.out') diff --git a/src/readgw.f b/src/readgw.f index 79a6000..726c88b 100644 --- a/src/readgw.f +++ b/src/readgw.f @@ -13,8 +13,10 @@ subroutine readgw !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! alpha_bf(:) |days |alpha factor for groundwater recession curve +!! alpha_bf(:) |1/days |alpha factor for groundwater recession curve +!! alpha_bf_d(:) | 1/days |alpha factor for groudwater recession curve of the deep aquifer !! alpha_bfe(:)|none |Exp(-alpha_bf(:)) +!! alpha_bfe_d (:) |1/days |Exp(-alpha_bf_d(:)) for deep aquifer !! ch_revap(:) |none |revap coeff: this variable controls the amount !! |of water moving from bank storage to the root !! |zone as a result of soil moisture depletion @@ -90,28 +92,30 @@ subroutine readgw read (110,*,iostat=eof) lat_orgn(ihru) if (eof < 0) exit read (110,*,iostat=eof) lat_orgp(ihru) + if (eof < 0) exit + read (110,*,iostat=eof) alpha_bf_d(ihru) exit end do + +!! set default values for mike van liew + if (hlife_ngw <= 0.) hlife_ngw = hlife_ngw_bsn +!! set default values for mike van liew !! set default values -!! Khan's changes -!! gw_revap(ihru) = 0.1 if (deepst(ihru) <= 0.) deepst(ihru) = 1000. if (hlife_ngw <= 0.) hlife_ngw = 365. if (lat_orgn(ihru) <= 1.e-6) lat_orgn(ihru) = 0. if (lat_orgp(ihru) <= 1.e-6) lat_orgp(ihru) = 0. - -!! set default values for mike van liew - if (hlife_ngw <= 0.) hlife_ngw = hlife_ngw_bsn -!! set default values for mike van liew - !! perform additional calculations alpha_bfe(ihru) = Exp(-alpha_bf(ihru)) if(delay(ihru) < .1) delay(ihru) = .1 gw_delaye(ihru) = Exp(-1./(delay(ihru) + 1.e-6)) shallst_n(ihru) = shallst_n(ihru) * shallst(ihru) / 100. gw_nloss(ihru) = Exp(-.693 / hlife_ngw) + +!! alpha baseflow factor for deep aquifer according to Yi Luo + alpha_bfe_d(ihru) = Exp(-alpha_bf_d(ihru)) !! assign values to channels diff --git a/src/readhru.f b/src/readhru.f index def540d..4acc1f2 100644 --- a/src/readhru.f +++ b/src/readhru.f @@ -178,6 +178,10 @@ subroutine readhru read (108,*,iostat=eof) soln_con(ihru) if (eof < 0) exit read (108,*,iostat=eof) solp_con(ihru) + if (eof < 0) exit + read (108,*,iostat=eof) pot_solpl(ihru) + if (eof < 0) exit + read (108,*,iostat=eof) pot_k(ihru) exit end do diff --git a/src/readinpt.f b/src/readinpt.f index 650e009..dc7d531 100644 --- a/src/readinpt.f +++ b/src/readinpt.f @@ -40,6 +40,14 @@ subroutine readinpt use parm +!! By Zhang for C/N cycling +!!============================== + !initilizaing several soil parameters + sol_WOC = 0. + sol_WON = 0. +!! By Zhang for C/N cycling +!!============================= + if (irtpest > 0) irtpest = nope(irtpest) npmx = 0 npmx = Sum(pstflg) !! set equal to # pesticides modeled in diff --git a/src/readmgt.f b/src/readmgt.f index b2243ca..40f0979 100644 --- a/src/readmgt.f +++ b/src/readmgt.f @@ -197,7 +197,7 @@ subroutine readmgt !! |plant) at which tillage occurs !! pst_kg(:,:,:) |kg/ha |amount of pesticide applied to HRU !! added for pesticide in incorporation in soil 3/31/08 gsm -!! pst_dep(:,:) |mm |depth of pesticide in the soil +!! pst_dep |mm |depth of pesticide in the soil !! sumix(:) |none |sum of all tillage mixing efficiencies !! |for HRU !! |operation @@ -502,6 +502,7 @@ subroutine readmgt end if if (mgt_op == 4 .or. mgt_op == 15) then newpest = 0 + hrupest(ihru) = 1 do j = 1, npmx if (mgt1i == npno(j)) then newpest = 1 diff --git a/src/readparmfile.f b/src/readparmfile.f deleted file mode 100644 index 4c51480..0000000 --- a/src/readparmfile.f +++ /dev/null @@ -1,6 +0,0 @@ - subroutine readparmfile - use parm - - - return - end \ No newline at end of file diff --git a/src/readplant.f b/src/readplant.f index d5dee3b..0efbeda 100644 --- a/src/readplant.f +++ b/src/readplant.f @@ -217,6 +217,7 @@ subroutine readplant & bmdieoff, rsr1c, rsr2c !! 777 format (7f8.3) 777 format (f8.3,i5,5f8.3) + if (eof < 0) exit if (ic <= 0) exit diff --git a/src/readpnd.f b/src/readpnd.f index ed82dc6..8199ec1 100644 --- a/src/readpnd.f +++ b/src/readpnd.f @@ -170,7 +170,7 @@ subroutine readpnd real :: swetmv, swetv, swets, swetns, swetk, sp2, sw1, sw2 real :: sn1, sn2, snw1, snw2, schla, schlaw, sseci, sseciw real :: spno3, spsolp, sporgn, sporgp, swno3, swsolp, sworgn - real :: sworgp, sub_ha + real :: sworgp, sub_ha, velsetlpnd eof = 0 spndfr = 0. @@ -345,7 +345,7 @@ subroutine readpnd close (104) !! Detention pond -- read from a separate file (.dpd) - if (dpd_file /= ' ' .or. ievent > 2) then + if (dpd_file /= ' ' .and. ievent > 2) then open (104,file=dpd_file) read (104,5100,iostat=eof) titldum if (eof < 0) exit @@ -406,7 +406,7 @@ subroutine readpnd !! END DETENTION POND FILE !! Wet pond (.wpd file) - if (wpd_file /= ' ' .or. ievent > 2) then + if (wpd_file /= ' ' .and. ievent > 2) then open (104,file=wpd_file) read (104,5100,iostat=eof) titldum if (eof < 0) exit @@ -472,7 +472,7 @@ subroutine readpnd !! end wet pond (.wpd file) !! Retention-Irrigation - if (rib_file /= ' '.or. ievent > 2) then + if (rib_file /= ' '.and. ievent > 2) then open (104,file=rib_file) read (104,5100,iostat=eof) titldum if (eof < 0) exit @@ -480,7 +480,6 @@ subroutine readpnd if (eof < 0) exit read (104,'(a200)',iostat=eof) lus if (eof < 0) exit - read (104,5100,iostat=eof) titldum do ii=2,len_trim(lus) num_noirr(i) = 1 @@ -496,6 +495,7 @@ subroutine readpnd if (eof < 0) exit end if + read (104,5100,iostat=eof) titldum read (104,*,iostat=eof) (ri_fr(i,k),k=1,num_ri(i)) if (eof < 0) exit read (104,*,iostat=eof) (ri_dim(i,k),k=1,num_ri(i)) @@ -522,7 +522,7 @@ subroutine readpnd !! end .rib file !! Sedimentaton-Filtration (.sfb file) - if (sfb_file /= ' '.or. ievent > 2) then + if (sfb_file /= ' '.and. ievent > 2) then open (104,file=sfb_file) read (104,'(a20)',iostat=eof) titldum if (eof < 0) exit diff --git a/src/readru.f b/src/readru.f index 2d59e37..20fd9c0 100644 --- a/src/readru.f +++ b/src/readru.f @@ -12,7 +12,7 @@ subroutine readru !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! da_ru |ha |area of routing unit -!! ovsl_ru |(m) |average slope length +!! ovsl |(m) |average slope length !! ovs_ru |(m) |average slope steepness !! ovn_ru | |Manning's N value overland flow !! chl_ru |(km) |channel length @@ -39,11 +39,13 @@ subroutine readru do read (113,5000,iostat=eof) titldum if (eof < 0) exit + read (113,*,iostat=eof) tck + if (eof < 0) exit read (113,*,iostat=eof) da_ru if (eof < 0) exit - read (113,*,iostat=eof) ovsl_ru + read (113,*,iostat=eof) ovsl if (eof < 0) exit - read (113,*,iostat=eof) ovs_ru + read (113,*,iostat=eof) ovs if (eof < 0) exit read (113,*,iostat=eof) ovn_ru if (eof < 0) exit @@ -60,10 +62,23 @@ subroutine readru exit end do + if (ovsl < 1.e-6) ovsl = 50. + do j = 1, hrutot(i) read (113,*) ix, hru_rufr(iru,j) end do + !! compute weighted K factor for sediment transport capacity + sumk = 0. + do j = 1, hrutot(i) + sumk = sumk + usle_k(j) * hru_rufr(iru,j) + end do + ru_k(isub,iru) = sumk + ru_ovsl(isub,iru) = ovsl + ru_ovs(isub,iru) = ovs + ru_ktc(isub,iru) = tck + daru_km(isub,iru) = da_ru + 5000 format (a) return end diff --git a/src/readsdr.f b/src/readsdr.f index 954f2b8..c676c9a 100644 --- a/src/readsdr.f +++ b/src/readsdr.f @@ -20,6 +20,7 @@ subroutine readsdr !! pc(:) |mm/hr |pump capacity (default pump capacity = 1.042mm/hr or 25mm/day) !! re(:) |mm |effective radius of drains !! sdrain(:) |mm |distance between two drain tubes or tiles +!! sstmaxd(:)|mm |static maximum depressional storage; read from .sdr !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ @@ -84,8 +85,10 @@ subroutine readsdr if (eof < 0) exit read (112,*,iostat=eof) pc(ihru) if (eof < 0) exit - read (112,*,iostat=eof) latksatf(ihru) - if (eof < 0) exit + read (112,*,iostat=eof) latksatf(ihru) + if (eof < 0) exit + read (112,*,iostat=eof) sstmaxd(ihru) + if (eof < 0) exit end do close (112) diff --git a/src/readsub.f b/src/readsub.f index d4476f8..2f59fa5 100644 --- a/src/readsub.f +++ b/src/readsub.f @@ -151,8 +151,7 @@ subroutine readsub ip = 0 if = 0 ir = 0 - - do + read (101,5100) titldum read (101,*) sub_km(i) if (isproj == 2) then @@ -258,21 +257,13 @@ subroutine readsub opsfile = "" septfile = "" sdrfile = "" -!! read (101,5300) hrufile, mgtfile, solfile, chmfile, gwfile, -!! & opsfile, ipot(j) read (101,5300) hrufile, mgtfile, solfile, chmfile, gwfile, - & opsfile, septfile, sdrfile + & opsfile, septfile, sdrfile, ils2(ihru) call caps(hrufile) call caps(mgtfile) call caps(solfile) call caps(chmfile) call caps(gwfile) -!$$$$$$ if (opsfile /= ' ') then -!$$$$$$ call caps(opsfile) -!$$$$$$ open (111,file=opsfile) -!$$$$$$ call readops -!$$$$$$ end if - if (septfile /=' ') then call caps (septfile) open (172,file=septfile, status='old') @@ -301,6 +292,17 @@ subroutine readsub call readops end if + ! set up variables for landscape routing +! if (ils_nofig == 1) then + if (ils2(ihru) == 0) then + ils = 1 + else + ils = 2 + ils2flag(i) = 1 + end if + daru_km(i,ils) = daru_km(i,ils) + hru_fr(j) * sub_km(i) +! end if + ! estimate drainage area for urban distributed bmps in hectares - jaehak if (urblu(ihru)>0) then kk=1 @@ -349,9 +351,23 @@ subroutine readsub end if ! estimate average Curve Number for the subbasin sub_cn2(i) = sub_cn2(i) + cn2(ihru) * hru_fr(ihru) + end do ! hru loop + + !! set up routing unit fractions for landscape routing + do j = jj, hrutot(i) + ihru = nhru + j + if (ils2(ihru) == 0) then + ils = 1 + else + ils = 2 + end if + end do - exit - end do + if (ils == 2) then + do j = jj, hrutot(i) + hru_rufr(ils,ihru) = hru_fr(ihru) * sub_km(i) / daru_km(i,ils) + end do + end if !! routing changes gsm per jga 5/3/2010 !! irunits = 0 @@ -367,9 +383,10 @@ subroutine readsub if (sdrain(ihru) <= 0.) sdrain(ihru) = sdrain_bsn if (drain_co(ihru) <= 0.) drain_co(ihru) = drain_co_bsn if (pc(ihru) <= 0.) pc(ihru) = pc_bsn - if (latksatf(ihru) <= 0.) latksatf(ihru) = latksatf_bsn + if (latksatf(ihru) <= 0.) latksatf(ihru) = latksatf_bsn + if (sstmaxd(ihru) <= 0.) sstmaxd(ihru) = sstmaxd_bsn ! estimate drainage area for urban on-line bmps in square km - subdr_km(i) = subdr_km(i) + sub_km(i) + !subdr_km(i) = subdr_km(i) + sub_km(i) !! set default values @@ -448,7 +465,7 @@ subroutine readsub 5100 format (a) 5101 format (f8.4,f4.2,5f8.3) 5200 format (10f8.1) - 5300 format (8a13) + 5300 format (8a13,i6) 5400 format (i4,6f8.3) 5500 format (2i4) end diff --git a/src/readtill.f b/src/readtill.f index 377e741..ed11331 100644 --- a/src/readtill.f +++ b/src/readtill.f @@ -41,7 +41,7 @@ subroutine readtill integer :: it, eof, itnum, j !! drainmod tile equations - addition random roughness 06/2006 - real :: emix, dtil, rrns + real :: emix, dtil, rrns !! drainmod tile equations - addition random roughness 06/2006 character (len=8) :: tlnm diff --git a/src/readwwq.f b/src/readwwq.f index 43d9ba6..e498bfa 100644 --- a/src/readwwq.f +++ b/src/readwwq.f @@ -153,7 +153,7 @@ subroutine readwwq !! convert units on k_l:read in as kJ/(m2*min), use as MJ/(m2*hr) k_l = k_l * 1.e-3 * 60. -!! change units from day to hour if hourly routing is performed +!! change units from day to hour if hourly (subdaily) routing is performed if (ievent == 3) then mumax = mumax / 24. rhoq = rhoq / 24. diff --git a/src/res.f b/src/res.f index f5d32dd..ab79e45 100644 --- a/src/res.f +++ b/src/res.f @@ -96,7 +96,7 @@ subroutine res integer :: jres real :: vol, sed, vvr, targ, xx, flw - real :: san,sil,cla,sag,lag,gra + real :: san,sil,cla,sag,lag,gra,ndespill real :: inised, finsed, setsed, remsetsed jres = 0 @@ -153,6 +153,13 @@ subroutine res case (1) !! use measured monthly outflow resflwo = res_out(jres,i_mo,curyr) + !! This will override the measured outflow! This is just a check + !! should really calibrate inflow or check res volumes + ndespill = ndtargr(nres) + if (ndespill <= 0.) ndespill = 10. + if (res_vol(jres) > res_evol(jres)) then + resflwo = resflwo+(res_vol(jres)-res_evol(jres))/ndespill + endif case (2) !! controlled outflow-target release targ = 0. diff --git a/src/resetlu.f b/src/resetlu.f index 7de4c32..f415289 100644 --- a/src/resetlu.f +++ b/src/resetlu.f @@ -41,7 +41,7 @@ subroutine resetlu !! reset all hru_fr variables do j = 1, mhru if (hru_fr(j) <= 0.) hru_fr(j) = .0000001 - hru_km(j) = sub_km(hru_sub(j)) * hru_fr(j) + hru_km(j) = sub_km(hru_sub(j)) * hru_fr(j) hru_ha(j) = hru_km(j) * 100. !MJW hru_dafr(j) = hru_km(j) / da_km !MJW do mon = 1, 12 @@ -61,8 +61,8 @@ subroutine resetlu wet_vol(j) = wet_vol(j) * hru_fr(j) hru_ha(j) = hru_km(j) * 100. ! pot_vol(j) = 10. * pot_volmm(j) * hru_ha(j) !! mm => m^3 NUBZ - pot_volx(j) = 10. * pot_volxmm(j) * hru_ha(j) !! mm => m^3 - pot_tile(j) = 10. * pot_tilemm(j) * hru_ha(j) !! mm => m^3 + pot_volx(j) = pot_volxmm(j) + pot_tile(j) = pot_tilemm(j) end do 5101 format (a80) diff --git a/src/rewind_init.f b/src/rewind_init.f index 49c26cb..9f6b190 100644 --- a/src/rewind_init.f +++ b/src/rewind_init.f @@ -40,6 +40,7 @@ subroutine rewind_init sno3up = 0. spadyev = 0. spadyo = 0. + spadyosp = 0. spadyrfv = 0. spadysp = 0. subaao = 0. @@ -65,6 +66,7 @@ subroutine rewind_init wshd_pas = 0. wshd_plch = 0. wshd_pstrs = 0. + wshd_astrs = 0. wshd_pup = 0. wshd_raino3 = 0. wshd_rmn = 0. diff --git a/src/route.f b/src/route.f index bd7ced3..4ae66ee 100644 --- a/src/route.f +++ b/src/route.f @@ -85,8 +85,8 @@ subroutine route call rchinit !! route overland flow - iru_sub = inum4 !!routing unit number - call routels(iru_sub) +!! iru_sub = inum4 !!routing unit number +!! call routels(iru_sub) vel_chan(jrch) = 0. dep_chan(jrch) = 0. diff --git a/src/routels.f b/src/routels.f index 4d2a4cf..1d5a8e5 100644 --- a/src/routels.f +++ b/src/routels.f @@ -34,25 +34,64 @@ subroutine routels(iru_sub) real :: ls_overq, ls_latq, ls_tileq, ls_gwq !! water - if (rnum1 > 1.e-4) return - xx = varoute(29,inum2) + varoute(30,inum2) + varoute(31,inum2) + - & varoute(32,inum2) - if (xx < 1.e-6) then - ls_overq = varoute(1,inum2) * rnum1 - ls_latq = 0. - ls_tileq = 0. - ls_gwq = 0. +! if (rnum1 > 1.e-4) return +! xx = varoute(29,inum2) + varoute(30,inum2) + varoute(31,inum2) + +! & varoute(32,inum2) +! if (xx < 1.e-6) then +! ls_overq = varoute(1,inum2) * rnum1 +! ls_latq = 0. +! ls_tileq = 0. +! ls_gwq = 0. +! else +! ls_overq = varoute(29,inum2) * rnum1 +! ls_latq = varoute(30,inum2) * rnum1 +! ls_tileq = varoute(31,inum2) * rnum1 +! ls_gwq = varoute(32,inum2) * rnum1 +! end if + + if (inum5 == 0 .or. inum8 == 0) then + ls_overq = 0. + surfqrunon = 0. + surfqout = 0. + if (inum5 == 0) then + ls_overq = varoute(29,inum2) * rnum1 + end if + if (inum8 == 0) then + ls_overq = ls_overq + varoute(31,inum2) * rnum1 + end if +!! sediment + sed = varoute(3,inum2) * rnum1 + !! use surface runoff (mm) for eiq - m3/(10 * 100*km2) = mm + ru_eiq(inum3,inum1) = ls_overq / (1000. * daru_km(inum3,inum1)) + trancap = ru_ktc(inum3,inum1) * ru_c(inum3,inum1) * & + & ru_eiq(inum3,inum1) * ru_k(inum3,inum1) * & + & ru_a(inum3,inum1)**1.4 * ru_ovs(inum3,inum1)**1.4 + trancap = trancap * daru_km(inum3,inum1) * 100. !! t/ha -> t + if (sed > trancap) then + varoute(3,ihout) = trancap + dr = varoute(3,ihout) / sed else - ls_overq = varoute(29,inum2) * rnum1 - ls_latq = varoute(30,inum2) * rnum1 - ls_tileq = varoute(31,inum2) * rnum1 - ls_gwq = varoute(32,inum2) * rnum1 + varoute(3,ihout) = sed + dr = 1. end if -!! sediment not routed + !! organic nitrogen orgn = varoute(4,inum2) * rnum1 + cy = varoute(3,inum2) / (varoute(2,inum2) + 1.e-6) + if (cy > .01) then + enratio = .78 * cy ** (-.2468) + else + enratio = 3. + end if + enratio = Min(enratio,3.) + dr_er = dr * enratio + dr_er = Min(dr_er,1.) + varoute(4,ihout) = orgn * dr_er + !! organic phosphorus orgp = varoute(5,inum2) * rnum1 + varoute(5,ihout) = orgp * dr_er + !! nitrate (& nitrite) no3 = (varoute(6,inum2) + varoute(15,inum2)) * rnum1 !! soluble phosphorus @@ -68,12 +107,6 @@ subroutine routels(iru_sub) !! less persistent bacteria not routed !! dstor = rnum1 - surfqrunon = 0. - latqrunon = 0. - gwqrunon = 0. - surfqout = 0. - latqout = 0. - gwqout = 0. !! compute infiltration from surface runon to next landscape unit if (ls_overq > 1.e-6) then @@ -84,11 +117,15 @@ subroutine routels(iru_sub) dakm = sub_km(inum3) else frac = hru_rufr(inum1,kk) - dakm = daru_km(inum1) + dakm = daru_km(inum3,inum1) end if if (frac > 1.e-9) then xx = frac * dakm * 100. !!km2*100 = ha surfqrunon = ls_overq / (10. * xx) + + if (pot_volxmm(jj) > 1.e-6) then + pot_vol(jj) = pot_vol(jj) + surfqrunon + else !! add surface runon to soil layers - use percmain like rainfall infiltration qs = surfqrunon / 24. @@ -105,15 +142,25 @@ subroutine routels(iru_sub) latqout = latqout + latq(jj) * 10. * xx gwqout = gwqout + sepbtm(jj) * 10. * xx end if + end if end do varoute(29,ihout) = varoute(29,ihout) + surfqout varoute(30,ihout) = varoute(30,ihout) + latqout varoute(32,ihout) = varoute(32,ihout) + gwqout + ! surfq_ru(jj) = surfqout / (10. * xx) + ! latq_ru(jj) = latqout / (10. * xx) + ! infl_ru(jj) = inflpcp + varoute(2,ihout) = varoute(2,ihout) + surfqout + latqout + & + & gwqout + end if end if !! compute lateral flow to next landscape unit + if (inum6 == 0) then + ls_latq = varoute(30,inum2) * rnum1 latqout = 0. - if (ls_latq > 1.e-6) then + latqrunon = 0. + if (ls_latq > 1.e-9) then do kk = 1, hrutot(inum3) jj= hru1(inum3) + kk - 1 if (iru_sub == 0) then @@ -121,7 +168,7 @@ subroutine routels(iru_sub) dakm = sub_km(inum3) else frac = hru_rufr(inum1,kk) - dakm = daru_km(inum1) + dakm = daru_km(inum3,inum1) end if if (frac > 1.e-9) then xx = frac * dakm * 100. !!km2*100 = ha @@ -145,12 +192,17 @@ subroutine routels(iru_sub) end if end do varoute(30,ihout) = varoute(30,ihout) + latqout + varoute(2,ihout) = varoute(2,ihout) + latqout + end if end if !! compute groundwater flow to next landscape unit - !! used the next day in gwmod - routed with recharge + if (inum7 == 0) then + ls_gwq = varoute(32,inum2) * rnum1 if (ls_gwq > 1.e-6) then gwqout = 0. + gwqrunon = 0. do kk = 1, hrutot(inum3) jj= hru1(inum3) + kk - 1 if (iru_sub == 0) then @@ -158,7 +210,7 @@ subroutine routels(iru_sub) dakm = sub_km(inum3) else frac = hru_rufr(inum1,kk) - dakm = daru_km(inum1) + dakm = daru_km(inum3,inum1) end if if (frac > 1.e-9) then xx = frac * dakm * 100. !!km2*100 = ha @@ -168,6 +220,7 @@ subroutine routels(iru_sub) end if end do end if + end if do ii = 29, mvaro varoute(ii,inum2) = 0. diff --git a/src/routeunit.f b/src/routeunit.f index 0f2e7c4..5ae9336 100644 --- a/src/routeunit.f +++ b/src/routeunit.f @@ -29,11 +29,17 @@ subroutine routeunit !! use parm - inum2 = 1 +! inum2 = 1 + varoute(:,ihout) = 0. + sumc = 0. + sumeiq = 0. do kk = 1, hrutot(inum2) - xx = hru_rufr(inum1,kk)* daru_km(inum1) * 100. !!km2*100 = ha + xx = hru_rufr(inum1,kk)* daru_km(inum2,inum1) * 100. !!km2*100 = ha if (xx > 1.e-9) then jj= hru1(inum2) + kk - 1 + sumc = sumc + usle_cfac(jj) * hru_rufr(inum1,kk) + sumeiq = sumeiq + usle_eifac(jj) * qdayout(jj) * & + & hru_rufr(inum1,kk) varoute(1,ihout) = 5.0 + 0.75 * tmpav(jj) varoute(2,ihout) = varoute(2,ihout) + qdr(jj) * xx * 10. !! mm*ha*10 = m3 varoute(3,ihout) = varoute(3,ihout) + sedyld(jj) !! t @@ -60,12 +66,14 @@ subroutine routeunit varoute(20,ihout) = 0. varoute(21,ihout) = 0. varoute(22,ihout) = 0. - varoute(29,ihout) = varoute(29,ihout) + surfq(jj) * xx * 10. + varoute(29,ihout) = varoute(29,ihout) + qdayout(jj) * xx * 10. varoute(30,ihout) = varoute(30,ihout) + latq(jj) * xx * 10. varoute(31,ihout) = varoute(31,ihout) + tileq(jj) * xx * 10. varoute(32,ihout) = varoute(32,ihout) + gw_q(jj) * xx * 10. end if end do + ru_c(inum2,inum1) = sumc + ru_eiq(inum2,inum1) = sumeiq return end diff --git a/src/rtbact.f b/src/rtbact.f index a1e6b8d..b8eca78 100644 --- a/src/rtbact.f +++ b/src/rtbact.f @@ -97,7 +97,7 @@ subroutine rtbact initp = 0. initlp = rch_bactlp(jrch) initp = rch_bactp(jrch) - do ii = 1, 24 + do ii = 1, nstep !! total bacteria mass in reach totbactp = 0. totbactlp = 0. diff --git a/src/rteinit.f b/src/rteinit.f index d0f7122..2340d0a 100644 --- a/src/rteinit.f +++ b/src/rteinit.f @@ -121,7 +121,7 @@ subroutine rteinit isb = hru_sub(idum) if (idplt(idum) > 0) then if (bio_e(idplt(idum)) > 1.e-6) then - subfr_nowtr(isb) = subfr_nowtr(isb) + hru_dafr(idum) + subfr_nowtr(isb) = subfr_nowtr(isb) + hru_fr(idum) end if end if end do diff --git a/src/rthpest.f b/src/rthpest.f index b86ad12..be5ed4a 100644 --- a/src/rthpest.f +++ b/src/rthpest.f @@ -106,7 +106,7 @@ subroutine rthpest bedvol = 0. bedvol = ch_w(2,jrch) * ch_l2(jrch) * 1000. * sedpst_act(jrch) - do ii = 1, 24 + do ii = 1, nstep !! initialize depth of water for pesticide calculations depth = 0. if (hdepth(ii) < 0.1) then @@ -150,7 +150,7 @@ subroutine rthpest if (chpstmass + sedpstmass < 1.e-6) return !!in-stream processes - if (hrtwtr(ii) / 3600. > 0.01) then + if (hrtwtr(ii) / (idt*60.) > 0.01) then !! calculated sediment concentration sedcon = 0. sedcon = hsedyld(ii) / hrtwtr(ii) * 1.e6 diff --git a/src/rthsed.f b/src/rthsed.f index 8eb4986..576637f 100644 --- a/src/rthsed.f +++ b/src/rthsed.f @@ -100,6 +100,7 @@ subroutine rthsed jrch = inum1 channel_d50 = ch_d50 / 1000. !! unit change mm->m particle_specific_gravity = 2.65 + sedin = 0. do ii = 1, nstep @@ -107,13 +108,13 @@ subroutine rthsed !! initialize water in reach during time step qin = 0. + sedin = 0. qin = hrtwtr(ii) + hhstor(ii) !! do not perform sediment routing if no water in reach if (qin > 0.01) then !! initialize sediment in reach during time step - sedin = 0. if (ii == 1) then sedin = hhvaroute(3,inum2,ii) * (1. - rnum1) + sedst(jrch) else @@ -167,12 +168,12 @@ subroutine rthsed !!critical shear stress for grain Froude number ycoeff = (sqrt(particle_specific_gravity - 1.) * - & Reynolds_g) ** -0.6 + & Reynolds_g) ** (-0.6) shear_stress = 0.22 * ycoeff + 0.06 * 10 ** (-7.7 * ycoeff) !! critical grain Froude number - fr_gc = 4.596 * shear_stress ** 0.5293 * ch_s(2,jrch) ** -0.1405 - & * sig_g ** -0.1606 + fr_gc = 4.596 * shear_stress ** 0.5293 * ch_s(2,jrch) ** (-0.1405) + & * sig_g ** (-0.1606) !! grain Froude number fr_g = vc / sqrt((particle_specific_gravity - 1.) * @@ -181,7 +182,7 @@ subroutine rthsed !! sediment concentration at the channel outlet [ppm, or g/m3] if(fr_g>fr_gc) then sedcon = 7115 * 1.268 * (fr_g - fr_gc) ** 1.978 * - & ch_s(2,jrch) ** 0.6601 * (rhy(ii) / channel_d50) ** -0.3301 + & ch_s(2,jrch) ** 0.6601 * (rhy(ii) / channel_d50) ** (-0.3301) else sedcon = 0. endif diff --git a/src/ruallo.f b/src/ruallo.f deleted file mode 100644 index 13eb13d..0000000 --- a/src/ruallo.f +++ /dev/null @@ -1,77 +0,0 @@ - subroutine ruallo - - use parm - - character (len=13) :: subfile, figfile - character (len=1) :: a - character (len=80) :: titldum - integer :: icd, inm1, inm2, inm3, iht, eof, numhru, ic - - icd = 1 - -!! process .fig file - do while (icd > 0) - read (25,5002) a - if (a /= "*") then - backspace 25 - - read (25,5001) a, icd, iht, inm1, inm2, inm3 - - select case (icd) - case (2) !! icd = 2 ROUTE command - mch = mch + 1 !! # channels - read (25,5002) a - case (3) !! icd = 3 ROUTE RESERVOIR command - mres = mres + 1 - read (25,5002) a - case (4) - read (25,5002) a !! icd = 4 TRANSFER command - mtran = mtran + 1 - case (6) !! icd = 6 RECALL HOUR command - read (25,5002) a - mrech = mrech + 1 - case (7) !! icd = 7 RECALL MONTH command - read (25,5002) a - mrecm = mrecm + 1 - case (8) !! icd = 8 RECALL YEAR command - read (25,5002) a - mrecy = mrecy + 1 - case (9) !! icd = 9 SAVE command - read (25,5002) a - nsave = nsave + 1 - case (10) !! icd = 10 RECALL DAY command - read (25,5002) a - mrecd = mrecd + 1 - case (11) !! icd = 11 RECALL CONSTANT command - read (25,5002) a - mrecc = mrecc + 1 - case (13) !! icd = 13 APEX command - read (25,5002) a - mapex = mapex + 1 - case (14) !! icd = 14 SAVECONC command - read (25,5002) a - nsave = nsave + 1 - case (16) !! icd = 16 AUTOCAL command - read (25,5002) a - nauto = nauto + 1 - case (17) !! icd = 17 ROUTE UNIT command - read (25,5002) a - mru = mru + 1 - end select - - mhyd = Max(mhyd,iht) - - end if - end do - - return - 5000 format (6a) - 5001 format (a1,9x,5i6) - 5002 format(a) - 5100 format (20a4) - 6000 format (a80) - 6100 format (10x,a13) - 6200 format (i3) - 6300 format (i4) - - end diff --git a/src/sat_excess.f b/src/sat_excess.f index ba062e5..5c95402 100644 --- a/src/sat_excess.f +++ b/src/sat_excess.f @@ -161,6 +161,7 @@ subroutine sat_excess(j1) end if if (j1 == 1 .and. ul_excess > 0.) then !! add ul_excess to depressional storage and then to surfq + pot_vol(j) = pot_vol(j) + ul_excess end if end do !compute tile flow again after saturation redistribution diff --git a/src/save.f b/src/save.f index ebcbe61..07ed478 100644 --- a/src/save.f +++ b/src/save.f @@ -44,8 +44,8 @@ subroutine save if (inum1 <= 10 .and. inum1 > 0) then if (ievent == 3 .and. inum2 == 1) then - !! Write hourly values - do ii = 1, 24 + !! Write subdaily values + do ii = 1, nstep if (inum3 == 0) then write (40+inum1,5000) iida, iyr, ii-1, & & hhvaroute(2,ihout,ii), & diff --git a/src/sched_mgt.f b/src/sched_mgt.f index e9d7aed..72e4683 100644 --- a/src/sched_mgt.f +++ b/src/sched_mgt.f @@ -4,6 +4,7 @@ subroutine sched_mgt !! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ @@ -108,6 +109,7 @@ subroutine sched_mgt hrupest(ihru) = 1 ipest = mgt1iop(nop(j),j) pst_kg = mgt4op(nop(j),j) + pst_dep = mgt5op(nop(j),j) call apply @@ -121,7 +123,7 @@ subroutine sched_mgt case (5) !! harvest and kill operation cnop = mgt4op(nop(j),j) hi_ovr = mgt5op(nop(j),j) - frac_harvk = mgt4op(nop(j),j) + frac_harvk = mgt6op(nop(j),j) biomass = bio_ms(j) call harvkillop @@ -159,7 +161,11 @@ subroutine sched_mgt harveff = mgt4op(nop(j),j) if (harveff <= 0.) then harveff = 1.0 - call harvestop + if (ihv_gbm == 0) then + call harvestop + else + call harvgrainop + end if if (imgt == 1) then write (143, 1001) subnum(j), hruno(j), iyr, i_mo, iida, diff --git a/src/sim_initday.f b/src/sim_initday.f index dff1899..5661dac 100644 --- a/src/sim_initday.f +++ b/src/sim_initday.f @@ -16,8 +16,6 @@ subroutine sim_initday !! flat(:,:) |mm H2O |lateral flow storage array !! frad(:,:) |none |fraction of solar radiation occuring during !! |hour in day in HRU -!! hhsubp(:,:) |mm H2O |precipitation falling during hour in day in -!! |HRU !! hru_ra(:) |MJ/m^2 |solar radiation for the day in HRU !! hru_rmx(:) |MJ/m^2 |maximum possible radiation for the day in HRU !! mo_chk |none |check for month being simulated; when mo_chk @@ -97,7 +95,6 @@ subroutine sim_initday flat = 0. frad = 0. ! gwq_ru = 0. - hhsubp = 0. hru_ra = 0. hru_rmx = 0. hrupstd = 0. @@ -154,6 +151,7 @@ subroutine sim_initday sub_hhwtmp = 0. sub_latno3 = 0. sub_latq = 0. + sub_tileq = 0. sub_minp = 0. sub_minpa = 0. sub_minps = 0. @@ -216,13 +214,41 @@ subroutine sim_initday latq = 0. sub_subp_dt = 0. sub_hhsedy = 0. - sub_atmp = 0. + sub_atmp = 0. rchhr = 0. - !! ri_pmpvol(:,:) = 0. - !! ri_totpvol(:) = 0. - !----------------------------------------------------- + !!add by zhang + !!========================== + sedc_d = 0. + surfqc_d =0. + latc_d = 0. + percc_d = 0. + foc_d = 0. + NPPC_d = 0. + rsdc_d = 0. + grainc_d = 0. + stoverc_d = 0. + emitc_d = 0. + soc_d = 0. + rspc_d = 0. + sub_sedc_d =0. + sub_surfqc_d=0. + sub_latc_d=0. + sub_percc_d=0. + sub_foc_d=0. + sub_NEPC_d=0. + sub_rsdc_d=0. + sub_grainc_d=0. + sub_stover_c_d=0. + sub_emit_c_d=0. + sub_soc_d =0. + sub_rspc_d =0. + !!add by zhang + !!========================== + + + return end diff --git a/src/sim_inityr.f b/src/sim_inityr.f index f4b7448..d3ae582 100644 --- a/src/sim_inityr.f +++ b/src/sim_inityr.f @@ -36,8 +36,6 @@ subroutine sim_inityr !! |within the year !! nirr(:) |none |sequence number of irrigation application !! |within the year -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! nrelease(:) |none |sequence number of impound/release operation !! |within the year !! nsweep(:) |none |sequence number of street sweeping operation @@ -57,7 +55,6 @@ subroutine sim_inityr use parm !! initialize variables/arrays at beginning of every year - npest = 1 ncpest = 1 nfert = 1 nrelease = 1 @@ -96,6 +93,35 @@ subroutine sim_inityr endif endif + !!add by zhang + !!================ + sedc_m = 0. + surfqc_m =0. + latc_m = 0. + percc_m = 0. + foc_m = 0. + NPPC_m = 0. + rsdc_m = 0. + grainc_m = 0. + stoverc_m = 0. + emitc_m = 0. + soc_m = 0. + rspc_m = 0. + + sedc_a = 0. + surfqc_a =0. + latc_a = 0. + percc_a = 0. + foc_a = 0. + NPPC_a = 0. + rsdc_a = 0. + grainc_a = 0. + stoverc_a = 0. + emitc_a = 0. + soc_a = 0. + rspc_a = 0. + !!add by zhang + !!================ return end diff --git a/src/smeas.f b/src/smeas.f index 397574d..2284c98 100644 --- a/src/smeas.f +++ b/src/smeas.f @@ -96,6 +96,8 @@ subroutine smeas end do return - 5200 format (7x,300f8.3) - 5300 format (i4,i3,300f8.3) +! 5200 format (7x,300f8.3) +! 5300 format (i4,i3,300f8.3) + 5200 format (7x,1800f8.3) + 5300 format (i4,i3,1800f8.3) end diff --git a/src/snom.f b/src/snom.f index 2654dd8..f502333 100644 --- a/src/snom.f +++ b/src/snom.f @@ -61,7 +61,6 @@ subroutine snom !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! hhprecip(:) |mm H2O |precipitation falling during hour in day !! precipday |mm H2O |amount of water in effective precipitation !! |in HRU !! precipdt(:) |mm H2O |precipitation for the time step during day @@ -164,10 +163,6 @@ subroutine snom precipday = smp + snomlt - snofall if (precipday < 0.) precipday = 0. if (nstep > 0) then - do ii = 1, 24 - hhprecip(ii) = hhprecip(ii) + (snomlt - snofall) / 24 - if (hhprecip(ii) < 0.) hhprecip(ii) = 0. - end do do ii = 1, nstep precipdt(ii+1) = precipdt(ii+1) + (snomlt - snofall) / nstep if (precipdt(ii+1) < 0.) precipdt(ii+1) = 0. @@ -189,7 +184,6 @@ subroutine snom sno_hru(j) = sno_hru(j) + precipday snofall = precipday precipday = 0. - hhprecip = 0. precipdt = 0. endif @@ -216,9 +210,6 @@ subroutine snom sno_hru(j) = sno_hru(j) - snomlt precipday = precipday + snomlt if (nstep > 0) then - do ii = 1, 24 - hhprecip(ii) = hhprecip(ii) + snomlt / 24 - end do do ii = 1, nstep precipdt(ii+1) = precipdt(ii+1) + snomlt / nstep end do diff --git a/src/soil_chem.f b/src/soil_chem.f index 10075f0..988d6f8 100644 --- a/src/soil_chem.f +++ b/src/soil_chem.f @@ -112,7 +112,23 @@ subroutine soil_chem integer :: nly, j, jj, n real :: xx, dg, wt1, zdst, soldepth, sumno3, sumorgn, summinp real :: sumorgp, solpst, soil_TP, labfrac,solp - + + !!by zhang + !!============= + real :: sol_mass + real :: FBM, FHP, RTNO, FHS, X1, RTO, sol_min_n + sol_mass = 0. + DG = 0. + FBM = 0. + FHP = 0. + RTNO = 0. + FHS = 0. + X1 = 0. + RTO = 0. + !!by zhang + !!============= + + nly = 0 solpst = 0. sumno3 = 0. @@ -275,5 +291,153 @@ subroutine soil_chem basminpi = basminpi + summinp * hru_km(i) / da_km basorgpi = basorgpi + sumorgp * hru_km(i) / da_km + !! By Zhang for C/N cycling + !!=============================== + if (cswat == 2) then + if (rsdin(i) > 0.) sol_rsd(1,i) = rsdin(i) + do j = 1, nly + !!kg/ha sol mass in each layer + if (j == 1) then + sol_mass = (sol_z(j,i)) / 1000. + !& 10000. * sol_bd(j,ihru)* 1000. * + !& (1- sol_rock(j,ihru) / 100.) + sol_mass = sol_mass * 10000. * sol_bd(j,i)* 1000. + sol_mass = sol_mass * (1- sol_rock(j,i) / 100.) + + else + sol_mass = (sol_z(j,i) - sol_z(j-1,i)) / 1000. + !& 10000. * sol_bd(j,ihru)* 1000. * + !& (1- sol_rock(j,ihru) / 100.) + sol_mass = sol_mass * 10000. * sol_bd(j,i)* 1000. + sol_mass = sol_mass * (1- sol_rock(j,i) / 100.) + end if + !!kg/ha mineral nitrogen + sol_min_n = sol_no3(j,i)+sol_nh3(j,i) + + !XCB = 0.2 + !mm + if (j == 1) then + !DG = 10 + DG = sol_z(j,i) + else + DG = (sol_z(j,i) - sol_z(j-1,i)) + end if + + !if(sol_WOC(j,ihru)<1.E-5) sol_WOC(j,ihru)=XCB*exp(-.001*DG) + + !XCB=sol_WOC(j,ihru) + !XZ=sol_WOC(j,ihru) *.0172 + !ZZ=1.-XZ + !sol_BDM(j,ihru)=ZZ/(1./sol_BD(j,ihru)-XZ/.224) + !if(sol_BDM(j,ihru)<1.)then + ! sol_BDM(j,ihru)=1. + ! sol_BD(j,ihru)=1./(ZZ+XZ/.224) + !end if + + + !ton/ha + !WT = sol_mass/1000. + + !WT1 = WT/1000. + !X1 = 10. * sol_cbn(j,ihru) * WT + !WT(J)=BD(J)*DG*10. + !DG1=DG + !WT1=WT(J)/1000. + !X1=10.*WOC(J)*WT(J) + !WOC(J)=X1 + !kg/ha + !sol_WOC(j,ihru)=X1 + sol_WOC(j,i) = sol_mass * sol_cbn(j,i)/100 + !if(sol_WON(j,ihru)>0.)then + ! sol_WON(j,ihru)=WT1*sol_WON(j,ihru) + ! KK=0 + !else + sol_WON(j,i) = sol_aorgn(j,i)+ sol_orgn(j,i)!0.1 * sol_WOC(j,i) + ! KK=1 + !end if + + !Frction of Mirobial Biomass, Humus Passive C pools + FBM = 0.0 + FHP = 0.0 + IF(FBM<1.E-10)FBM=.04 + RTN0 = 100. + IF(FHP<1.E-10)FHP=.7-.4*EXP(-.0277*100) + FHS = 1 - FBM - FHP + !From DSSAT + !FBM = 0.02 + !FHS = 0.54 + !FHP = 0.44 + + !NCC = 0 + !IF(NCC==0)THEN + !sol_WBM(j,ihru)=FBM*X1 + sol_BM(j,i)=FBM*sol_WOC(j,i) + sol_BMC(j,i)=sol_BM(j,i) + !IF(KK==0)THEN + RTO=sol_WON(j,i)/sol_WOC(j,i) + !ELSE + ! RTO=.1 + !END IF + sol_BMN(j,i)=RTO*sol_BMC(j,i) + !sol_HP(j,ihru)=FHP*(X1-sol_BM(j,ihru)) + sol_HP(j,i)=FHP*(sol_WOC(j,i)-sol_BM(j,i)) + sol_HS(j,i)=sol_WOC(j,i)-sol_BM(j,i)-sol_HP(j,i) + !sol_HP(j,i)=sol_WOC(j,i)-sol_BM(j,i)-sol_HP(j,i) + sol_HSC(j,i)=sol_HS(j,i) + sol_HSN(j,i)= RTO*sol_HSC(j,i) !sol_aorgn(j,i) + sol_HPC(j,i)=sol_HP(j,i) + sol_HPN(j,i)= RTO*sol_HPC(j,i) !sol_orgn(j,i) + + + X1=sol_rsd(j,i) /1000. + !!skip std in SWAT + !IF(j==1)X1=X1+STD(j)/1000. + + sol_LM(j,i)=500.*X1 + sol_LS(j,i)=sol_LM(j,i) + sol_LSL(j,i)=.8*sol_LS(j,i) + sol_LMC(j,i)=.42*sol_LM(j,i) + + sol_LMN(j,i)=.1*sol_LMC(j,i) + sol_LSC(j,i)=.42*sol_LS(j,i) + sol_LSLC(j,i)=.8*sol_LSC(j,i) + sol_LSLNC(j,i)=.2*sol_LSC(j,i) + sol_LSN(j,i)=sol_LSC(j,i)/150. + !sol_WOC(j,ihru)=sol_WOC(j,ihru)+sol_LSC(j,ihru)+sol_WLMC(j,ihru) + sol_WOC(j,i)=sol_WOC(j,i)+sol_LSC(j,i)+sol_LMC(j,i) + !sol_WON(j,ihru)=sol_WON(j,ihru)+sol_LSN(j,ihru)+sol_WLMN(j,ihru) + sol_WON(j,i)=sol_WON(j,i)+sol_LSN(j,i)+sol_LMN(j,i) + !END IF + + !if (sol_orgn(j,i) > 0.0001) then + ! sol_orgn(j,i) = sol_orgn(j,i) * wt1 !! mg/kg => kg/ha + !else + !! assume C:N ratio of 10:1 + ! sol_orgn(j,i) = 10000. * (sol_cbn(j,i) / 11.) * wt1 !! CN ratio was 14 before 01-22-09 Armen + !end if + sol_orgn(j,i) = sol_HPN(j,i) + sol_aorgn(j,i) = sol_HSN(j,i) + sol_fon(1,i) = sol_LMN(j,i) + sol_LSN(j,i) + !sol_aorgn(j,i) = sol_orgn(j,i) * nactfr + !sol_orgn(j,i) = sol_orgn(j,i) * (1. - nactfr) + sumorgn = sumorgn + sol_aorgn(j,i) + sol_orgn(j,i) + + & sol_fon(j,i) + sol_BMN(j,i) + + + end do + + end if + !! By Zhang for C/N cycling + !!=============================== + + + !!May need to think about moving the following lines which appear before in this module to the end of this module, + !!because orgn has been re-calculated. + !!============================ + !basno3i = basno3i + sumno3 * hru_km(i) / da_km + !basorgni = basorgni + sumorgn * hru_km(i) / da_km + !basminpi = basminpi + summinp * hru_km(i) / da_km + !basorgpi = basorgpi + sumorgp * hru_km(i) / da_km + return end diff --git a/src/soil_write.f b/src/soil_write.f index 571eb3a..32abe07 100644 --- a/src/soil_write.f +++ b/src/soil_write.f @@ -32,11 +32,26 @@ subroutine soil_write do l = 1,sol_nly(j) solp_t = solp_t + sol_solp(l,j) solno3_t = solno3_t + sol_no3(l,j) + !if (cswat == 0) then + ! solorgn_t = solorgn_t + sol_orgn(l,j) + !else + ! solorgn_t = solorgn_t + sol_n(l,j) + !end if + + !!By Zhang + !!============ if (cswat == 0) then solorgn_t = solorgn_t + sol_orgn(l,j) - else + end if + if (cswat == 1) then solorgn_t = solorgn_t + sol_n(l,j) - end if + end if + if (cswat ==2) then + solorgn_t = solorgn_t + sol_HSN(l,j) + sol_HPN(l,j) + end if + !!By Zhang + !!============ + solorgp_t = solorgp_t + sol_orgp(l,j) end do write (121,1000) i, subnum(j), hruno(j), sol_rsd(1,j), solp_t, & diff --git a/src/std2.f b/src/std2.f index d10aabd..35eefbc 100644 --- a/src/std2.f +++ b/src/std2.f @@ -238,36 +238,36 @@ subroutine std2 & /t10,' Sub Length(km) Slope Width(m) Cond(mm/hr) N', & & 1x,'Length(km) Slope Width(m) Depth(m) Cond(mm/hr) N', & & ' MSK_K') - 1014 format (t10,i4,2x,f10.2,f6.3,f9.2,f12.4,1x,f5.3,1x,f10.2,f6.3, & + 1014 format (t10,i6,2x,f10.2,f6.3,f9.2,f12.4,1x,f5.3,1x,f10.2,f6.3, & & 2f9.2,f12.4,1x,f5.3,1x,f6.3) 1020 format (/t10,'HRU Input Summary Table 1:',/t10, & & ' Sub HRU Area(ha) Slope SlpLgth(m) Ovrlnd_N CondII_CN'& & ,' TimeConc(hr) ESCO EPCO') - 1021 format (t10,i4,1x,i5,f11.2,f6.3,f11.2,f9.3,f10.2,f13.3,2f5.2) + 1021 format (t10,i4,1x,i6,f11.2,f6.3,f11.2,f9.3,f10.2,f13.3,2f5.2) 1022 format (/t10,'HRU Input Summary Table 2:',/t10, & & ' Sub HRU Area(ha) SoilName Hydgrp MaxRtDpth', & & '(mm) Albedo USLE_K USLE_P USLE_LS ProfileAWC(mm) IniSoil',& & 'H2O(mm)') - 1023 format (t10,i4,1x,i5,f11.2,1x,a16,3x,a1,3x,f14.2,3f7.2,f8.2,f11.3,& + 1023 format (t10,i4,1x,i6,f11.2,1x,a16,3x,a1,3x,f14.2,3f7.2,f8.2,f11.3,& & f15.3) 1024 format (/t10,'HRU Input Summary Table 3:',/t10, & & ' Sub HRU Area(ha) Urban Irrig DrainTiles Pothole', & & ' Pstcide Biomix Septic') - 1025 format (t10,i4,1x,i5,f11.2,3x,a1,5x,a1,8x,a1,8x,a1,6x,a1,5x,f6.2, & + 1025 format (t10,i4,1x,i6,f11.2,3x,a1,5x,a1,8x,a1,8x,a1,6x,a1,5x,f6.2, & & 1x,a1) 1026 format (/t10,'HRU Input Summary Table 4 (Groundwater):',/t10, & & ' Sub HRU Area(ha) GWdelay(days), GWalpha(days)', & & ' GWQmin(mm) GWrevap Revapmin(mm) Deepfr NO3(ppm)', & & ' SolP(ppm)') - 1027 format (t10,i4,1x,i5,f11.2,2f14.3,f11.3,f8.3,f13.3,f7.3,f9.3, & + 1027 format (t10,i4,1x,i6,f11.2,2f14.3,f11.3,f8.3,f13.3,f7.3,f9.3, & & f10.3) 1028 format (/t10,'HRU CN Input Summary Table:',/t10, & & ' Sub HRU Area(ha) LULC Soil CN1 CN2 ', & & 'CN3 Wilting Point (mm H2O) Field Capacity (mm H2O)', & & ' Saturation (mm H2O)') - 1029 format (t10,i4,1x,i5,f11.2,2x,a4,2x,a8,3f7.1,18x,f6.1,19x,f6.1, & + 1029 format (t10,i4,1x,i6,f11.2,2x,a4,2x,a8,3f7.1,18x,f6.1,19x,f6.1, & & 15x,f6.1) - 1030 format (t10,i4,1x,i5,f11.2,2x,'BARR',2x,a8,3f7.1,18x,f6.1,19x,f6.1 & + 1030 format (t10,i4,1x,i6,f11.2,2x,'BARR',2x,a8,3f7.1,18x,f6.1,19x,f6.1 & & ,15x,f6.1) 2000 format (//,' AREA DOES NOT SUM TO ONE ', f8.6,//) 3000 format (i4,3f12.4) diff --git a/src/std3.f b/src/std3.f index 6de82ac..72a44dd 100644 --- a/src/std3.f +++ b/src/std3.f @@ -37,19 +37,28 @@ subroutine std3 1100 format (/(t5,20a4)) 1200 format ('Annual Summary for Watershed in year ',i4, & & ' of simulation',/) - 1300 format (' UNIT',t36,'PERCO',t44,'TILE',t71,'WATER',t80,'SED',t87, & +1300 format ('UNIT',t41,'PERCO',t50,'TILE',t81,'WATER',t91,'SED',t99, & + &'NO3',t107,'NO3',t115,'NO3',t123,'NO3',t134,'N',t142,'P',t150,'P',& + &/,'TIME',t10,'PREC',t18,'SURQ',t26,'LATQ',t35,'GWQ',t42,'LATE', & + &t53,'Q',t59,'SW',T68,'ET',t75,'PET',t81,'YIELD',t89,'YIELD',t98, & + &'SURQ',t106,'LATQ',t114,'PERC',t122,'CROP',t128,'ORGANIC',t136, & + &'SOLUBLE',t144,'ORGANIC',t152,'TILENO3'/,t10,'(mm)',t18,'(mm)', & + &t26,'(mm)',t34,'(mm)',t42,'(mm)',t50,'(mm)',t58,'(mm)',t66,'(mm)',& + &t74,'(mm)',t82,'(mm)',t90,'(mm)',t97'------------------(kg nutrien& + &t/ha)--------------------',t152,'(kg/ha)') +! 1300 format (' UNIT',t36,'PERCO',t44,'TILE',t71,'WATER',t80,'SED',t87, & ! & 'NO3',t94,'NO3',t101,'NO3',t108,'NO3',t119,'N',t127,'P',t135, & - & 'NO3',t94,'NO3',t101,'NO3',t108,'NO3',t119,'N',t127, & - & 'P P', +! & 'NO3',t94,'NO3',t99,'NO3',t104,'NO3',t115,'N',t123, & +! & 'P P', ! & 'P',/,' TIME',t9,'PREC',t16,'SURQ',t23,'LATQ',t31,'GWQ',t37, & - & /,' TIME',t9,'PREC',t16,'SURQ',t23,'LATQ',t31,'GWQ',t37, & - & 'LATE',t47,'Q',t52,'SW',t59,'ET',t66,'PET',t71,'YIELD',t78, & - & 'YIELD',t86,'SURQ',t93,'LATQ',t100,'PERC',t107,'CROP',t113, & - & 'ORGANIC',t121,'SOLUBLE',t129,'ORGANIC',t139,'TILENO3'/, & - & t9,'(mm)',t16,'(mm)' & +! & /,' TIME',t10,'PREC',t16,'SURQ',t23,'LATQ',t31,'GWQ',t37, & +! & 'LATE',t47,'Q',t52,'SW',t59,'ET',t66,'PET',t71,'YIELD',t78, & +! & 'YIELD',t86,'SURQ',t93,'LATQ',t98,'PERC',t104,'CROP',t111, & +! & 'ORGANIC',t119,'SOLUBLE',t127,'ORGANIC',t135,'TILENO3'/, & +! & t9,'(mm)',t16,'(mm)' & ! & 'ORGANIC',t121,'SOLUBLE',t129,'ORGANIC',/,t9,'(mm)',t16,'(mm)'& - & ,t23,'(mm)',t30,'(mm)',t37,'(mm)',t44,'(mm)',t51,'(mm)',t58, & - & '(mm)',t65,'(mm)',t72,'(mm)',t77,'(t/ha)',t85, & - & '-----------------(kg nutrient/ha)------------------', & - & t139,'(kg/ha)') +! & ,t23,'(mm)',t30,'(mm)',t37,'(mm)',t44,'(mm)',t51,'(mm)',t58, & +! & '(mm)',t65,'(mm)',t72,'(mm)',t77,'(t/ha)',t85, & +! & '-----------------(kg nutrient/ha)-----------------', & +! & t135,'(kg/ha)') end diff --git a/src/stdaa.f b/src/stdaa.f index c189886..8780539 100644 --- a/src/stdaa.f +++ b/src/stdaa.f @@ -261,7 +261,7 @@ subroutine stdaa !! wshdaao(46) |kg N/ha |nitrate percolation past bottom of soil !! |profile in watershed for the simulation !! wshdaao(104)|mm H2O |groundwater contribution to stream in -!! |watershed for the simulation +!! |watershed for the simulation (shallow aquifer) !! wshdaao(105)|mm H2O |amount of water moving from shallow aquifer !! |to plants/soil profile in watershed during !! |simulation @@ -273,6 +273,8 @@ subroutine stdaa !! |for the simulation !! wshdaao(109)|mm H2O |drainage tile flow contribution to stream !! |in watershed for the simulation +!! wshdaao(113)|mm H2O |groundwater contribution to stream in +!! |watershed for the simulation (deep aquifer) !! yldaa(:) |metric tons/ha|average annual yield (dry weight) in HRU !! yldn(:,:,:) |kg/ha |average value for yield of crop !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ @@ -372,9 +374,9 @@ subroutine stdaa write (26,1900) j, hru_sub(j), & & snam(j), hru_km(j), cn2(j), sol_sumfc(j), usle_ls(j), & & hruaao(22,j), hruaao(28,j), hruaao(29,j), sumix(j), & - & hruaao(1,j), hruaao(4,j), hruaao(5,j) + hruaao(6,j), & + & hruaao(1,j), hruaao(19,j), hruaao(5,j) + hruaao(6,j), & & hruaao(12,j), hruaao(14,j), hruaao(37,j) + hruaao(38,j), & - & hruaao(35,j), bio_aams(j), yldaa(j) + & hruaao(35,j), bio_aams(j), yldaa(j), hruaao(4,j) end do else if (isproj == 1) then write (19,1700) @@ -388,9 +390,9 @@ subroutine stdaa write (19,1900) j, hru_sub(j), cropname, & snam(j), hru_km(j), cn2(j), sol_sumfc(j), usle_ls(j), & & hruaao(22,j), hruaao(28,j), hruaao(29,j), sumix(j), & - & hruaao(1,j), hruaao(4,j), hruaao(5,j) + hruaao(6,j), & + & hruaao(1,j), hruaao(19,j), hruaao(5,j) + hruaao(6,j), & & hruaao(12,j), hruaao(14,j), hruaao(37,j) + hruaao(38,j), & - & hruaao(35,j), bio_aams(j), yldaa(j) + & hruaao(35,j), bio_aams(j), yldaa(j), hruaao(4,j) end do endif @@ -409,9 +411,11 @@ subroutine stdaa !! write average annual stress values if (iscen == 1) then - write (26,2200) wshd_wstrs, wshd_tstrs, wshd_nstrs, wshd_pstrs + write (26,2200) wshd_wstrs, wshd_tstrs, wshd_nstrs, wshd_pstrs, & + & wshd_astrs else if (isproj == 1) then - write (19,2200) wshd_wstrs, wshd_tstrs, wshd_nstrs, wshd_pstrs + write (19,2200) wshd_wstrs, wshd_tstrs, wshd_nstrs, wshd_pstrs, & + & wshd_astrs endif !! watershed summary water balance table @@ -419,7 +423,7 @@ subroutine stdaa write (26,1000) prog write (26,1100) title write (26,2300) wshdaao(1), wshdaao(39), wshdaao(36), wshdaao(37),& - & wshdaao(3), wshdaao(4), wshdaao(109), wshdaao(104), & + & wshdaao(3), wshdaao(4),wshdaao(109),wshdaao(104),wshdaao(113),& & wshdaao(105), wshdaao(106), wshdaao(107), wshdaao(6), & & wshdaao(5), wshdaao(7), wshdaao(108), wshdaao(38), & & wshd_sepmm, wshdaao(12) @@ -431,7 +435,7 @@ subroutine stdaa write (19,1000) prog write (19,1100) title write (19,2300) wshdaao(1), wshdaao(39), wshdaao(36), wshdaao(37),& - & wshdaao(3), wshdaao(4), wshdaao(109), wshdaao(104), & + & wshdaao(3), wshdaao(4),wshdaao(109),wshdaao(104),wshdaao(113),& & wshdaao(105), wshdaao(106), wshdaao(107), wshdaao(6), & & wshdaao(5), wshdaao(7), wshdaao(108), wshdaao(38), & & wshdaao(12) @@ -445,9 +449,9 @@ subroutine stdaa ! sumpady = Sum(ipot) ! if (sumpady > 0) then if (iscen == 1) then - write (26,2500) spadyo, spadyev, spadysp, spadyrfv + write (26,2500) spadyo, spadyev, spadysp, spadyosp else if (isproj == 1) then - write (19,2500) spadyo, spadyev, spadysp, spadyrfv + write (19,2500) spadyo, spadyev, spadysp, spadyosp endif ! end if @@ -519,16 +523,16 @@ subroutine stdaa !! 1600 format (1x,'HRU ',i6,1x,6(a4,' Yld =',f8.1,1x,'BIOM = ',f8.1,2x)) 1600 format (1x,' HRU ',i7,' SUB',i4,1x,6(a4,' Yld =',f8.1,1x, * 'BIOM = ',f8.1,2x)) - 1601 format (1x,i6,a) + 1601 format (1x,' HRU ',i7,a) 1602 format (1x,'HRU ',i6,1x,6(a4,2f8.1,2x)) 1700 format (/t5,'HRU STATISTICS'//t17,'AVE ANNUAL VALUES'/) 1800 format (3x,'HRU',t8,' SUB',t14,'SOIL',t25,'AREAkm2', & & t36,'CN', & & t43,'AWCmm',t51,'USLE_LS',t60,'IRRmm',t67,'AUTONkh ',t75, & - & 'AUTOPkh ',t84,'MIXEF',t91,'PRECmm',t99,'SURQmm',t107, & - & 'GWQmm',t115,'ETmm',t124,'SEDth ',t132,'NO3kgh ',t140, & - & 'ORGNkgh ',t148,'BIOMth',t156,'YLDth') - 1900 format (i7,i4,3x,a8,3x,e8.3,16f8.2) + & 'AUTOPkh ',t84,'MIXEF',t90,'PRECmm',t97,'SURQGENmm',t109, & + & 'GWQmm',t118,'ETmm',t125,'SEDth ',t132,'NO3kgh ',t140, & + & 'ORGNkgh ',t148,'BIOMth',t157,'YLDth',t164,'SURQmm') + 1900 format (i7,i4,3x,a8,3x,e8.3,17f8.2) 2000 format (///,t17,'AVE MONTHLY BASIN VALUES',/t20,'SNOW',t46, & & 'WATER',t66,'SED',/t3,'MON',t11,'RAIN',t20,'FALL',t27,'SURF Q',& & t37,'LAT Q',t46,'YIELD',t58,'ET',t64,'YIELD',t75,'PET',/t11, & @@ -539,7 +543,8 @@ subroutine stdaa & ' WATER STRESS DAYS = ',f8.2,/,t15, & & ' TEMPERATURE STRESS DAYS = ',f8.2,/,t15, & & ' NITROGEN STRESS DAYS = ',f8.2,/,t15, & - & ' PHOSPHORUS STRESS DAYS = ',f8.2) + & ' PHOSPHORUS STRESS DAYS = ',f8.2,/,t15, & + & ' AERATION STRESS DAYS = ',f8.2) 2300 format (t10,'AVE ANNUAL BASIN VALUES'// & & t15,'PRECIP = ',f8.1,' MM'/ & & t15,'SNOW FALL =',f8.2,' MM'/ & @@ -549,6 +554,7 @@ subroutine stdaa & t15,'LATERAL SOIL Q =',f8.2,' MM'/ & & t15,'TILE Q = ',f8.2,' MM'/ & & t15,'GROUNDWATER (SHAL AQ) Q = ',f8.2,' MM'/ & + & t15,'GROUNDWATER (DEEP AQ) Q = ',f8.2,' MM'/ & & t15,'REVAP (SHAL AQ => SOIL/PLANTS) =',f8.2,' MM'/ & & t15,'DEEP AQ RECHARGE = ',f8.2,' MM'/ & & t15,'TOTAL AQ RECHARGE =',f8.2,' MM'/ & @@ -579,10 +585,10 @@ subroutine stdaa ! 2400 format (t15,'YIELD LOSS FROM PONDS'/t20,'WATER = ',f7.3,' MM'/t20,& ! & 'SEDIMENT = ',f7.3,' T/HA'/t15,'YIELD LOSS FROM RESERVOIRS'/ & ! & t20,'WATER = ',f8.3,' MM'/t20,'SEDIMENT = ',f7.3,' T/HA') - 2500 format (t15,'OUTFLOW FROM IMPOUNDED WATER = ',f8.3,' (MM)',/,t15,& + 2500 format (t15,'TILE FROM IMPOUNDED WATER = ',f8.3,' (MM)',/,t15, & & 'EVAPORATION FROM IMPOUNDED WATER = ',f8.3,' (MM)',/,t15, & & 'SEEPAGE INTO SOIL FROM IMPOUNDED WATER = ',f8.3,' (MM)',/,t15& - & ,'RAINFALL ON IMPOUNDED WATER = ',f8.3,' (MM)') + & ,'OVERFLOW FROM IMPOUNDED WATER = ',f8.3,' (MM)') 2600 format (t15,'AVE ANNUAL BASIN VALUES') 2700 format (//,t15,'NUTRIENTS',/,t20,'ORGANIC N = ',f8.3,' (KG/HA)', & & /,t20,'ORGANIC P = ',f8.3,' (KG/HA)',/,t20, & diff --git a/src/structure.f b/src/structure.f index d0690c6..2b40d9d 100644 --- a/src/structure.f +++ b/src/structure.f @@ -103,7 +103,7 @@ subroutine structure !! subdaily array if (ievent > 2) then - do ii = 1, 24 + do ii = 1, nstep do jj = 1, mvaro hhvaroute(jj,ihout,ii) = hhvaroute(jj,inum1,ii) end do diff --git a/src/sub_subbasin.f b/src/sub_subbasin.f index ce932e5..d1f0128 100644 --- a/src/sub_subbasin.f +++ b/src/sub_subbasin.f @@ -55,8 +55,6 @@ subroutine sub_subbasin !! |within the year !! nirr(:) |none |sequence number of irrigation application !! |within the year -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! nrelease(:) |none |sequence number of impound/release !! |operation within the year !! nro(:) |none |sequence number of year in rotation diff --git a/src/subbasin.f b/src/subbasin.f index c070318..73643c3 100644 --- a/src/subbasin.f +++ b/src/subbasin.f @@ -54,8 +54,6 @@ subroutine subbasin !! |within the year !! nirr(:) |none |sequence number of irrigation application !! |within the year -!! npest(:) |none |sequence number of pesticide application -!! |within the year !! nrelease(:) |none |sequence number of impound/release !! |operation within the year !! nro(:) |none |sequence number of year in rotation @@ -124,7 +122,7 @@ subroutine subbasin !! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ !! Intrinsic: Exp, Max !! SWAT: varinit, albedo, solt, surface, percmain, etpot, etact, fert -!! SWAT: confert, graze, plantmod, nminrl, nitvol, pminrl, gwmod, apply +!! SWAT: confert, graze, plantmod, nminrl, nitvol, pminrl, gwmod, apply, gwmod_deep !! SWAT: washp, decay, pestlch, enrsb, pesty, orgn, psed, nrain, nlch !! SWAT: solp, subwq, bacteria, urban, pothole, latsed, surfstor !! SWAT: substor, wetland, hrupond, irrsub, autoirr, watuse, watbal @@ -147,10 +145,33 @@ subroutine subbasin j = 0 j = ihru + + !!by zhang DSSAT tillage + !!====================== + !! deptil(:) |mm |depth of mixing caused by tillage operation + !jj is hru number + if (cswat == 2) then + if (tillage_switch(ihru) .eq. 1) then + if (tillage_days(ihru) .ge. 30) then + tillage_switch(ihru) = 0 + tillage_days(ihru) = 0 + else + tillage_days(ihru) = tillage_days(ihru) + 1 + end if + !tillage_depth(ihru) = dtil + !tillage_switch(ihru) = .TRUE. + end if + end if + !!by zhang DSSAT tillage + !!====================== + + + call varinit if (icr(j) <= 0) icr(j) = 1 i_wtrhru = 0 + idplrot(icr(j),ihru) = idplt(j) if (idplt(j) /= 0) then if (cpnm(idplt(j)) == "WATR") then i_wtrhru = 1 @@ -183,6 +204,10 @@ subroutine subbasin !! undrained depression-- call surface + !! add surface flow that was routed across the landscape on the previous day + !! qday = qday + surfq_ru(j) + !! surfq_ru(j) = 0. + !! compute effective rainfall (amount that percs into soil) inflpcp = Max(0.,precipday - surfq(j)) ! end if @@ -197,7 +222,8 @@ subroutine subbasin !! compute evapotranspiration call etpot - if (pot_vol(j) < 1.e-6) call etact +! if (pot_vol(j) < 1.e-6) call etact + call etact !! compute water table depth using climate drivers call wattable @@ -210,7 +236,6 @@ subroutine subbasin sci(j) = sci(j) + pet_day*exp(-cncoef_sub(hru_sub(j))*sci(j)/ & & smx(j)) - precipday + qday + latq(j) + sepbtm(j) + qtile sci(j) = amin1(sci(j),smxco * smx(j)) - !! write (1225,*) sci(j) end if !! apply fertilizer/manure in continuous fert operation @@ -249,9 +274,18 @@ subroutine subbasin if (cswat == 0) then call nminrl - else + end if + if (cswat == 1) then call carbon - end if + end if + + !! Add by zhang + !!================= + if (cswat == 2) then + call carbon_zhang2 + end if + !! Add by zhang + !!================= call nitvol if (sol_P_model == 1) then @@ -268,6 +302,7 @@ subroutine subbasin !! compute ground water contribution call gwmod + call gwmod_deep !! compute pesticide washoff if (precipday >= 2.54) call washp @@ -285,9 +320,19 @@ subroutine subbasin if (cswat == 0) then call orgn(0) - else + end if + if (cswat == 1) then + call orgncswat(0) end if + + !! Add by zhang + !! ==================== + if (cswat == 2) then + call orgncswat2(0) + end if + !! Add by zhang + !! ==================== call psed(0) end if @@ -341,6 +386,10 @@ subroutine subbasin call substor + !! add lateral flow that was routed across the landscape on the previous day + !! latq(j) = latq(j) + latq_ru(j) + !! latq_ru(j) = 0. + !! compute reduction in pollutants due to edge-of-field filter strip if (vfsi(j) >0.)then call filter @@ -363,7 +412,7 @@ subroutine subbasin !! compute water yield for HRU - qdr(j) = qday + latq(j) + gw_q(j) + qtile + qdr(j) = qday + latq(j) + gw_q(j) + qtile + gw_qdeep(j) if (qdr(j) < 0.) qdr(j) = 0. if (qdr(j) > 0.) then qdfr = qday / qdr(j) @@ -394,6 +443,9 @@ subroutine subbasin !! perform water balance call watbal + + !! qdayout is surface runoff leaving the hru - after wetlands, ponds, and potholes + qdayout(j) = qday endif @@ -408,6 +460,79 @@ subroutine subbasin ihru = ihru + 1 end do + !! route 2 landscape units + if (ils2flag(inum1) > 0) then + isub = inum1 ! save the subbasin number + + !! calculate outputs from hillslope + ihout1 = mhyd_bsn + (inum1 - 1) * 4 ! first outflow hyd number + ihout = ihout1 ! outflow hyd number + inum1 = 1 ! landscape unit number + inum2 = isub ! subbasin number + call routeunit ! hillslope unit + call sumhyd + inum1s(ihout) = inum1 + inum2s(ihout) = inum2 + ihouts(ihout) = ihout + + !! calculate outputs from valley bottom + inum1 = 2 ! landscape unit number + ihout = ihout + 1 ! outflow hyd number + sumdaru = 0. + do j = 1, hrutot(isub) + sumdaru = sumdaru + hru_km(j) + end do + daru_km(inum2,inum1) = sumdaru + call routeunit ! valley bottom unit + call sumhyd + inum1s(ihout) = inum1 + inum2s(ihout) = inum2 + ihouts(ihout) = ihout + + !! route output from hillslope across valley bottom + ihout = ihout + 1 ! outflow hyd number + inum1 = 2 ! valley bottom landscape unit + inum2 = ihout1 ! inflow hyd=outlfow from hillslope + inum3 = isub ! subbasin number + rnum1 = 1. ! fraction overland flow + iru_sub = 1 ! route across landscape unit + !! compute weighted K factor for sediment transport capacity + sumk = 0. + ovsl = 0. + ovs = 0. + do j = 1, hrutot(isub) + sumk = sumk + usle_k(j) * hru_rufr(inum1,j) + ovsl = ovsl + slsubbsn(j) + ovs = ovs + hru_slp(j) + end do + ovsl = ovsl / hrutot(isub) + ovs = ovs / hrutot(isub) + ru_k(isub,inum1) = sumk + ru_ovsl(isub,inum1) = ovsl + ru_ovs(isub,inum1) = ovs + ru_ktc(isub,inum1) = 50. + ru_a(isub,inum1) = daru_km(isub,1) / ru_ovsl(isub,inum1) + call routels(iru_sub) ! route across valley bottom + call sumhyd + inum1s(ihout) = inum1 + inum2s(ihout) = inum2 + inum3s(ihout) = inum3 + ihouts(ihout) = ihout + + !! add routed with valley bottom loading + inum1 = ihout ! hyd from routed + inum2 = ihout - 1 ! hyd from loading + ihout = ihout + 1 ! outflow hyd number + call addh ! add hyd's + call sumhyd + inum1s(ihout) = inum1 + inum2s(ihout) = inum2 + ihouts(ihout) = ihout + + !! save landscape routed output in place of subbasin output for routing + varoute(isub,:) = varoute(ihout,:) + end if + 1000 format(4i10,a10) return end diff --git a/src/subwq.f b/src/subwq.f index 6227fda..9d83650 100644 --- a/src/subwq.f +++ b/src/subwq.f @@ -96,7 +96,16 @@ subroutine subwq !! calculate organic carbon loading to main channel org_c = 0. org_c = (sol_cbn(1,j) / 100.) * enratio * sedyld(j) * 1000. - + + !!add by zhang + !!======================== + if (cswat == 2) then + org_c = sedc_d(j)*hru_ha(j) + end if + !!add by zhang + !!======================== + + !! calculate carbonaceous biological oxygen demand (CBOD) cbodu(j) = 2.7 * org_c / (qdr(j) * hru_km(j)) diff --git a/src/sumv.f b/src/sumv.f index fe8fd32..fb9aaf2 100644 --- a/src/sumv.f +++ b/src/sumv.f @@ -454,7 +454,7 @@ subroutine sumv hrumono(1,j) = hrumono(1,j) + subp(j) hrumono(2,j) = hrumono(2,j) + snofall hrumono(3,j) = hrumono(3,j) + snomlt - hrumono(4,j) = hrumono(4,j) + qday + tloss + hrumono(4,j) = hrumono(4,j) + qday hrumono(5,j) = hrumono(5,j) + latq(j) hrumono(6,j) = hrumono(6,j) + gw_q(j) hrumono(7,j) = hrumono(7,j) + revapday @@ -519,6 +519,8 @@ subroutine sumv hrumono(67,j) = hrumono(67,j) + sedminpa(j) + sedminps(j) hrumono(68,j) = hrumono(68,j) + tileno3(j) hrumono(69,j) = hrumono(69,j) + latno3(j) + hrumono(70,j) = hrumono(70,j) + gw_qdeep(j) + hrumono(71,j) = hrumono(71,j) + latq(j) - lpndloss - lwetloss wtrmon(1,j) = wtrmon(1,j) + pndev / cnv wtrmon(2,j) = wtrmon(2,j) + pndsep / cnv @@ -545,7 +547,7 @@ subroutine sumv !! watershed summations if (ffcst == 0 .and. iscen == 1) then wshddayo(1) = wshddayo(1) + subp(j) * hru_dafr(j) - wshddayo(3) = wshddayo(3) + (qday + tloss) * hru_dafr(j) + wshddayo(3) = wshddayo(3) + surfq(j) * hru_dafr(j) wshddayo(4) = wshddayo(4) + latq(j) * hru_dafr(j) wshddayo(5) = wshddayo(5) + sepbtm(j) * hru_dafr(j) wshddayo(6) = wshddayo(6) + qdr(j) * hru_dafr(j) @@ -593,6 +595,7 @@ subroutine sumv wshddayo(109) = wshddayo(109) + qtile * hru_dafr(j) wshddayo(110) = wshddayo(110) + no3gw(j) * hru_dafr(j) wshddayo(111) = wshddayo(111) + tileno3(j) * hru_dafr(j) + wshddayo(113) = wshddayo(113) + gw_qdeep(j) * hru_dafr(j) do ii=1,mstdo if(wshddayo(ii).ne.wshddayo(ii)) wshddayo(ii) = 0 !! float error debug, Jaehak Jeong, 2011 Feb end do diff --git a/src/surface.f b/src/surface.f index 7d767f1..00ba668 100644 --- a/src/surface.f +++ b/src/surface.f @@ -69,9 +69,6 @@ subroutine surface !! add overland flow from upstream routing unit precipday = precipday + ovrlnd(j) if (nstep > 0) then - do ii = 1, 24 - hhprecip(ii) = hhprecip(ii) + ovrlnd(j) / 24. - end do do ii = 1, nstep precipdt(ii+1) = precipdt(ii+1) + ovrlnd_dt(j,ii) end do @@ -135,6 +132,7 @@ subroutine surface call ovr_sed end if + call cfactor if (surfq(j) > 1.e-6 .and. peakr > 1.e-6) call ysed(0) if (qday < 0.) qday = 0. diff --git a/src/surfst_h2o.f b/src/surfst_h2o.f index 49760a3..237f911 100644 --- a/src/surfst_h2o.f +++ b/src/surfst_h2o.f @@ -54,7 +54,7 @@ subroutine surfst_h2o j = 0 j = ihru - if (ievent < 3) then + if (ievent < 2) then bsprev = surf_bs(1,j) surf_bs(1,j) = Max(1.e-6, surf_bs(1,j) + surfq(j)) diff --git a/src/surfstor.f b/src/surfstor.f index fa79113..cfe9071 100644 --- a/src/surfstor.f +++ b/src/surfstor.f @@ -200,7 +200,7 @@ subroutine surfstor end do end if - sedyld(j) = surf_bs(2,j) * brt(j) + !! sedyld(j) = surf_bs(2,j) * brt(j) <----line of code in x 2. fixes sedyld low prob sanyld(j) = surf_bs(13,j) * brt(j) silyld(j) = surf_bs(14,j) * brt(j) diff --git a/src/surq_greenampt.f b/src/surq_greenampt.f index c28b9b1..51ed1fa 100644 --- a/src/surq_greenampt.f +++ b/src/surq_greenampt.f @@ -166,7 +166,7 @@ subroutine surq_greenampt hhqday(k-1) = hhqday(k-1) * (1.- fcimp(urblu(j))) !runoff from impervious area with initial abstraction - ubnrunoff(k-1) = (precipdt(k-1) - abstinit) * + ubnrunoff(k-1) = (precipdt(k) - abstinit) * & fcimp(urblu(j)) if ( ubnrunoff(k-1)<0) ubnrunoff(k-1) = 0. end if diff --git a/src/swu.f b/src/swu.f index d1806dc..54abbf1 100644 --- a/src/swu.f +++ b/src/swu.f @@ -127,10 +127,14 @@ subroutine swu if (sol_sw(j) > sol_sumfc(j)) then satco = (sol_sw(j) - sol_sumfc(j)) / (sol_sumul(j) - & sol_sumfc(j)) - strsa(j) = 1. - (satco / (satco + Exp(.176 - 4.544 * - & satco))) - else - strsa(j) = 1. + pl_aerfac = .85 + scparm = 100. * (satco - pl_aerfac) / (1.0001 - pl_aerfac) + if (scparm > 0.) then + strsa(j) = 1. - (scparm / (scparm + Exp(2.9014 - .03867 * + & scparm))) + else + strsa(j) = 1. + end if end if do k = 1, sol_nly(j) @@ -151,12 +155,12 @@ subroutine swu end if !! don't allow compensation for aeration stress - if (strsa(j) > .99) then - yy = 0. - else - yy= sump - xx - end if - wuse(k) = sum - sump + yy * epco(j) +! if (strsa(j) > .99) then +! yy = 0. +! else +! yy= sump - xx +! end if + wuse(k) = sum - sump + 1. * epco(j) wuse(k) = sum - sump + (sump - xx) * epco(j) sump = sum @@ -179,9 +183,6 @@ subroutine swu ! wuse(k) = 0. ! endif ! endif - - - !! adjust uptake if sw is less than 25% of plant available water reduc = 0. diff --git a/src/tair.f b/src/tair.f index 2b69d20..e04568d 100644 --- a/src/tair.f +++ b/src/tair.f @@ -39,7 +39,8 @@ function tair(hr,jj) use parm - integer, intent (in) :: hr, jj + integer, intent (in) :: jj + real, intent(in) :: hr real :: tair !! update hi or lo temperature depending on hour of day diff --git a/src/tmeas.f b/src/tmeas.f index 161d6a4..5023a54 100644 --- a/src/tmeas.f +++ b/src/tmeas.f @@ -122,9 +122,11 @@ subroutine tmeas end do return - 5000 format (7x,600f5.1) - 5100 format (i4,i3,600f5.1) - 5200 format (7x,600f8.3) - 5300 format (i4,i3,600f8.3) + !! 5000 format (7x,600f5.1) + !! 5100 format (i4,i3,600f5.1) +!5000 format (7x,900f5.1) +!5100 format (i4,i3,900f5.1) +5000 format (7x,3600f5.1) +5100 format (i4,i3,3600f5.1) end diff --git a/src/ttcoef.f b/src/ttcoef.f index 9f0778e..2587e76 100644 --- a/src/ttcoef.f +++ b/src/ttcoef.f @@ -85,7 +85,7 @@ subroutine ttcoef(k) d = 0. !! If side slope is not set in .rte file then assume this default !! If it is main reach default side slope to 2:1 if it is a waterway default to 8:1 - if (chsslope <= 1.e-6) then + if (chside(k) <= 1.e-6) then chsslope = 2. else chsslope = chside(k) diff --git a/src/ttcoef_wway.f b/src/ttcoef_wway.f index 47742a5..b84a288 100644 --- a/src/ttcoef_wway.f +++ b/src/ttcoef_wway.f @@ -86,7 +86,7 @@ subroutine ttcoef_wway !! If side slope is not set in .rte file then assume this default !! If it is main reach default side slope to 2:1 if it is a waterway default to 8:1 - if (chsslope <= 1.e-6) then + if (chside(k) <= 1.e-6) then chsslope = 8. else chsslope = chside(k) diff --git a/src/urb_bmp.f b/src/urb_bmp.f index 473183d..a3a3460 100644 --- a/src/urb_bmp.f +++ b/src/urb_bmp.f @@ -34,34 +34,28 @@ subroutine urb_bmp sedpppm = xx * (sedorgp(j) + sedminpa(j) + sedminps(j)) if (sedppm > sed_con (j)) then - sedyld(j) = sedyld(j) * ((1. - pot_fr(j)) + pot_fr(j) * - * sed_con(j) * hru_ha(j) / xx / 1000.) + sedyld(j) = sed_con(j) * hru_ha(j) / xx / 1000. endif if (solnppm > soln_con(j)) then - rto = (soln_con(j) / xx) / (surqno3(j) + latno3(j) + no3gw(j)) - surqno3(j) = surqno3(j) * (rto * pot_fr(j) + (1.-pot_fr(j))) - latno3(j) = latno3(j) * (rto * pot_fr(j) + (1.-pot_fr(j))) - no3gw(j) = no3gw(j) * (rto * pot_fr(j) + (1.-pot_fr(j))) + surqno3(j) = soln_con(j) / xx + latno3(j) = soln_con(j) / xx + no3gw(j) = soln_con(j) / xx endif if (solpppm > solp_con(j)) then - rto = (solp_con(j) / xx) / (surqsolp(j) + minpgw(j)) - surqsolp(j) = surqsolp(j) * (rto * pot_fr(j) + (1.-pot_fr(j))) - minpgw(j) = minpgw(j) * (rto * pot_fr(j) + (1. - pot_fr(j))) + surqsolp(j) = solp_con(j) / xx + minpgw(j) = solp_con(j) / xx endif if (sednppm > orgn_con(j)) then - sedorgn(j) = sedorgn(j) * (pot_fr(j) * orgn_con(j) / xx + - * (1. - pot_fr(j))) + sedorgn(j) = orgn_con(j) / xx endif if (sedpppm > orgp_con(j)) then - rto = (orgp_con(j) / xx) / (sedorgp(j) + sedminpa(j) + - * sedminps(j)) - sedorgn(j)=sedorgp(j) * (rto * pot_fr(j) + (1. - pot_fr(j))) - sedminpa(j)=sedminpa(j) * (rto * pot_fr(j) + (1. - pot_fr(j))) - sedminps(j)=sedminps(j) * (rto * pot_fr(j) + (1. - pot_fr(j))) + sedorgn(j)= orgp_con(j) / xx + sedminpa(j)= orgp_con(j) / xx + sedminps(j)= orgp_con(j) / xx endif endif diff --git a/src/urbanhr.f b/src/urbanhr.f index 0c3774e..ef8adcb 100644 --- a/src/urbanhr.f +++ b/src/urbanhr.f @@ -115,15 +115,7 @@ subroutine urbanhr select case (iurban(j)) - case (1) !! USGS regression equations - - write(*,*) "USGS regression equations are not available in - & the subdaily simulation." - write(*,*) "Change the urban management parameter (IURBAN) - & to buildup/washoff (IURBAN=2) in the management files" -!! stop - - case (2) !! build-up/wash-off algorithm + case (1,2) !! build-up/wash-off algorithm !! rainy day: no build-up, street cleaning allowed diff --git a/src/varinit.f b/src/varinit.f index 5d4eaf7..96c9c30 100644 --- a/src/varinit.f +++ b/src/varinit.f @@ -8,8 +8,6 @@ subroutine varinit !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! deepst(:) |mm H2O |depth of water in deep aquifer -!! hhsubp(:,:) |mm H2O |precipitation falling during hour in day in -!! |HRU !! ihru |none |HRU number !! nstep |none |number of lines of rainfall data for each !! |day @@ -77,7 +75,6 @@ subroutine varinit !! |on the day in HRU !! gwseep |mm H2O |amount of water recharging deep aquifer on !! |current day -!! hhprecip(:) |mm H2O |precipitation falling during hour in day !! hhqday(:) |mm H2O |surface runoff from HRU for every hour in day !! hmntl |kg N/ha |amount of nitrogen moving from active !! |organic to nitrate pool in soil profile @@ -233,10 +230,6 @@ subroutine varinit grazn = 0. grazp = 0. gwseep = 0. - hhprecip = 0. - do ii = 1, 24 - hhprecip(ii) = hhsubp(j,ii) - end do hhqday = 0. hmntl = 0. hmptl = 0. diff --git a/src/virtual.f b/src/virtual.f index 2fe9074..68e1993 100644 --- a/src/virtual.f +++ b/src/virtual.f @@ -29,7 +29,7 @@ subroutine virtual !! gw_q(:) |mm H2O |groundwater contribution to streamflow from !! |HRU on current day !! hhqday(:) |mm H2O |surface runoff for the hour in HRU -!! hru_dafr(:) |none |fraction of watershed area in HRU +!! hru_fr(:) |none |fraction of watershed area in HRU !! hru_fr(:) |none |fraction of subbasin area in HRU !! hru_ha(:) |ha |area of HRU in hectares !! ievent |none |rainfall/runoff code @@ -264,7 +264,7 @@ subroutine virtual use parm integer :: j, sb, kk, ii - real :: cnv, sub_ha, wtmp, baseflw, bf_fr + real :: cnv, sub_ha, wtmp, baseflw, bf_fr,hr real :: sub_hwyld(nstep), hqd(3*nstep), hsd(3*nstep),hqdtst(nstep) ! hqd, hsd locally defined. J.Jeong 4/26/2009 j = ihru @@ -272,52 +272,50 @@ subroutine virtual cnv = hru_ha(j) * 10. !! write daily HRU output - if (iprint == 1 .and. curyr > nyskip) call hruday - if (iprint == 1 .and. curyr > nyskip) call impndday + if ((iprint==1.or.iprint==3) .and. curyr > nyskip) call hruday + if ((iprint==1.or.iprint==3) .and. curyr > nyskip) call impndday !! sum HRU results for subbasin if (sb > 0) then !! subbasin averages: water - sub_subp(sb) = sub_subp(sb) + subp(j) * hru_dafr(j) - sub_snom(sb) = sub_snom(sb) + snomlt * hru_dafr(j) - sub_pet(sb) = sub_pet(sb) + pet_day * hru_dafr(j) - sub_etday(sb) = sub_etday(sb) + etday * hru_dafr(j) - sub_sumfc(sb) = sub_sumfc(sb) + sol_sumfc(j) * hru_dafr(j) - sub_sw(sb) = sub_sw(sb) + sol_sw(j) * hru_dafr(j) - sub_sep(sb) = sub_sep(sb) + sepbtm(j) * hru_dafr(j) - sub_qd(sb) = sub_qd(sb) + qday * hru_dafr(j) - sub_gwq(sb) = sub_gwq(sb) + gw_q(j) * hru_dafr(j) - sub_wyld(sb) = sub_wyld(sb) + qdr(j) * hru_dafr(j) - sub_latq(sb) = sub_latq(sb) + latq(j) * hru_dafr(j) - sub_subp_dt(sb,:) = sub_subp_dt(sb,:) + rainsub(j,:) * hru_fr(j) !!urban modeling by J.Jeong + sub_subp(sb) = sub_subp(sb) + subp(j) * hru_fr(j) + sub_snom(sb) = sub_snom(sb) + snomlt * hru_fr(j) + sub_pet(sb) = sub_pet(sb) + pet_day * hru_fr(j) + sub_etday(sb) = sub_etday(sb) + etday * hru_fr(j) + sub_sumfc(sb) = sub_sumfc(sb) + sol_sumfc(j) * hru_fr(j) + sub_sw(sb) = sub_sw(sb) + sol_sw(j) * hru_fr(j) + sub_sep(sb) = sub_sep(sb) + sepbtm(j) * hru_fr(j) + sub_qd(sb) = sub_qd(sb) + qday * hru_fr(j) + sub_gwq(sb) = sub_gwq(sb) + gw_q(j) * hru_fr(j) + sub_gwq_d(sb) = sub_gwq_d(sb) + gw_qdeep(j) * hru_fr(j) + sub_wyld(sb) = sub_wyld(sb) + qdr(j) * hru_fr(j) + sub_latq(sb) = sub_latq(sb) + latq(j) * hru_fr(j) + sub_subp_dt(sb,:) = sub_subp_dt(sb,:) + rainsub(j,:) * hru_fr(j) !!urban modeling by J.Jeong !! subbasin averages: sub-daily water for URBAN MODELING - if (ievent>2) then + if (ievent>1) then do ii = 1, nstep !! step Oct. 18, 2007 if (bmpdrain(j)==1) then !Urban HRUs where runoff drains to bmps - sub_ubnrunoff(sb,ii) = sub_ubnrunoff(sb,ii) + - & (hhqday(ii) + ubnrunoff(ii)) * hru_dafr(j) !J.Jeong - if (sub_ubnrunoff(sb,ii) < 1.e-20) sub_ubnrunoff(sb,ii) = 0. - sub_ubntss(sb,ii) = sub_ubntss(sb,ii) + - & (hhsedy(j,ii) + ubntss(ii)) * hru_dafr(j) !J.Jeong - if (sub_ubntss(sb,ii) < 1.e-20) sub_ubntss(sb,ii) = 0. + sub_ubnrunoff(sb,ii) = sub_ubnrunoff(sb,ii) + & + (hhqday(ii) + ubnrunoff(ii)) * hru_fr(j) !J.Jeong + if (sub_ubnrunoff(sb,ii) < 1.e-20) sub_ubnrunoff(sb,ii) = 0. + sub_ubntss(sb,ii) = sub_ubntss(sb,ii) + & + (hhsedy(j,ii) + ubntss(ii)) * hru_fr(j) !J.Jeong + if (sub_ubntss(sb,ii) < 1.e-20) sub_ubntss(sb,ii) = 0. else !Urban/non-urban HRUs that do not make runoff to BMPs - sub_hhqd(sb,ii) = sub_hhqd(sb,ii) + - & (hhqday(ii) + ubnrunoff(ii)) * hru_dafr(j) + sub_hhqd(sb,ii) = sub_hhqd(sb,ii) + & + (hhqday(ii) + ubnrunoff(ii)) * hru_fr(j) if (sub_hhqd(sb,ii) < 1.e-20) sub_hhqd(sb,ii) = 0. - sub_hhsedy(sb,ii) = sub_hhsedy(sb,ii) + - & (hhsedy(j,ii) + ubntss(ii)) * hru_dafr(j) + sub_hhsedy(sb,ii) = sub_hhsedy(sb,ii) + & + (hhsedy(j,ii) + ubntss(ii)) * hru_fr(j) if (sub_hhsedy(sb,ii) < 1.e-20) sub_hhsedy(sb,ii) = 0. end if - - !! water temperature, equation 2.3.13 in SWAT manual - sub_atmp(sb,ii) = sub_atmp(sb,ii) + Tair(ii,j) * hru_fr(j) - sub_hhwtmp(sb,ii) = sub_hhwtmp(sb,ii) + hru_fr(j) * - & (5.0 + 0.75 * sub_atmp(sb,ii)) - + !air temperature + hr = ii * idt / 60. + sub_atmp(sb,ii) = sub_atmp(sb,ii) + Tair(hr,j) * hru_fr(j) end do end if @@ -342,16 +340,16 @@ subroutine virtual !! subbasin averages: nutrients if (latno3(j) < 1.e-6) latno3(j) = 0.0 - sub_no3(sb) = sub_no3(sb) + surqno3(j) * hru_dafr(j) - sub_latno3(sb) = sub_latno3(sb) + latno3(j) * hru_dafr(j) - sub_tileno3(sb) = sub_tileno3(sb) + tileno3(j) * hru_dafr(j) - sub_gwno3(sb) = sub_gwno3(sb) + no3gw(j) * hru_dafr(j) - sub_solp(sb) = sub_solp(sb) + surqsolp(j) * hru_dafr(j) - sub_gwsolp(sb) = sub_gwsolp(sb) + minpgw(j) * hru_dafr(j) - sub_yorgn(sb) = sub_yorgn(sb) + sedorgn(j) * hru_dafr(j) - sub_yorgp(sb) = sub_yorgp(sb) + sedorgp(j) * hru_dafr(j) - sub_sedpa(sb) = sub_sedpa(sb) + sedminpa(j) * hru_dafr(j) - sub_sedps(sb) = sub_sedps(sb) + sedminps(j) * hru_dafr(j) + sub_no3(sb) = sub_no3(sb) + surqno3(j) * hru_fr(j) + sub_latno3(sb) = sub_latno3(sb) + latno3(j) * hru_fr(j) + sub_tileno3(sb) = sub_tileno3(sb) + tileno3(j) * hru_fr(j) + sub_gwno3(sb) = sub_gwno3(sb) + no3gw(j) * hru_fr(j) + sub_solp(sb) = sub_solp(sb) + surqsolp(j) * hru_fr(j) + sub_gwsolp(sb) = sub_gwsolp(sb) + minpgw(j) * hru_fr(j) + sub_yorgn(sb) = sub_yorgn(sb) + sedorgn(j) * hru_fr(j) + sub_yorgp(sb) = sub_yorgp(sb) + sedorgp(j) * hru_fr(j) + sub_sedpa(sb) = sub_sedpa(sb) + sedminpa(j) * hru_fr(j) + sub_sedps(sb) = sub_sedps(sb) + sedminps(j) * hru_fr(j) !! subbasin averages: pesticides if (irtpest > 0) then @@ -362,9 +360,9 @@ subroutine virtual !! subbasin averages: bacteria sub_bactp(sb) = sub_bactp(sb) + (bactrop + bactsedp) - & * hru_dafr(j) + & * hru_fr(j) sub_bactlp(sb) = sub_bactlp(sb) + (bactrolp + bactsedlp) - & * hru_dafr(j) + & * hru_fr(j) !! subbasin averages: water quality indicators sub_chl(sb) = sub_chl(sb) + chl_a(j) * (qday * qdfr * cnv) @@ -379,23 +377,32 @@ subroutine virtual !! from air temperature. Water Res. Bull. p. 27-45 wtmp = 0. wtmp = 5.0 + 0.75 * tmpav(j) - sub_wtmp(sb) = sub_wtmp(sb) + wtmp * qdr(j) * hru_dafr(j) + sub_wtmp(sb) = sub_wtmp(sb) + wtmp * qdr(j) * hru_fr(j) !! subbasin averages used in subbasin sediment calculations - wcklsp(sb) = wcklsp(sb) + cklsp(j) * hru_dafr(j) - sub_precip(sb) = sub_precip(sb) + precipday * hru_dafr(j) - sub_surfq(sb) = sub_surfq(sb) + surfq(j) * hru_dafr(j) - sub_tran(sb) = sub_tran(sb) + tloss * hru_dafr(j) - sub_bd(sb) = sub_bd(sb) + sol_bd(1,j) * hru_dafr(j) + wcklsp(sb) = wcklsp(sb) + cklsp(j) * hru_fr(j) + sub_precip(sb) = sub_precip(sb) + precipday * hru_fr(j) + sub_surfq(sb) = sub_surfq(sb) + surfq(j) * hru_fr(j) + sub_tran(sb) = sub_tran(sb) + tloss * hru_fr(j) + sub_bd(sb) = sub_bd(sb) + sol_bd(1,j) * hru_fr(j) if (cswat == 0) then sub_orgn(sb) = sub_orgn(sb) + (sol_orgn(1,j) + - & sol_aorgn(1,j) + sol_fon(1,j)) * hru_dafr(j) - else + & sol_aorgn(1,j) + sol_fon(1,j)) * hru_fr(j) + end if + if (cswat == 1) then sub_orgn(sb) = sub_orgn(sb) + (sol_n(1,j) + sol_fon(1,j) + - & sol_mn(1,j)) * hru_dafr(j) + & sol_mn(1,j)) * hru_fr(j) + end if + !!add by zhang + !!====================== + if (cswat == 2) then + sub_orgn(sb) = sub_orgn(sb) + (sol_LMN(1,j) + sol_LSN(1,j) + + & sol_HPN(1,j)+sol_HSN(1,j)+sol_BMN(1,j)) * hru_dafr(j) end if + !!add by zhang + !!====================== ! do kk = 1, mp - ! sub_pst(kk,sb) = sub_pst(kk,sb) + sol_pst(k,j,1) * hru_dafr(j) + ! sub_pst(kk,sb) = sub_pst(kk,sb) + sol_pst(k,j,1) * hru_fr(j) ! end do end if !! end subbasin summarization calculations @@ -413,8 +420,10 @@ subroutine virtual sub_sep(sb) = sub_sep(sb) / subfr_nowtr(sb) sub_qd(sb) = sub_qd(sb) / subfr_nowtr(sb) sub_gwq(sb) = sub_gwq(sb) / subfr_nowtr(sb) + sub_gwq_d(sb) = sub_gwq_d(sb) / subfr_nowtr(sb) sub_wyld(sb) = sub_wyld(sb) / subfr_nowtr(sb) sub_latq(sb) = sub_latq(sb) / subfr_nowtr(sb) + sub_tileq(sb) = sub_tileq(sb) / subfr_nowtr(sb) else sub_snom(sb) = 0.0 sub_sumfc(sb) = 0.0 @@ -424,34 +433,38 @@ subroutine virtual sub_gwq(sb) = 0.0 sub_wyld(sb) = 0.0 sub_latq(sb) = 0.0 + sub_tileq(sb) = 0.0 end if - sub_subp(sb) = sub_subp(sb) / sub_fr(sb) - sub_pet(sb) = sub_pet(sb) / sub_fr(sb) - sub_etday(sb) = sub_etday(sb) / sub_fr(sb) - - if (ievent > 2) then - - ! subdaily surface runoff, upland sediment for the subbasin - do ii = 1, nstep - sub_hhqd(sb,ii) = sub_hhqd(sb,ii) / sub_fr(sb) - sub_ubnrunoff(sb,ii) = sub_ubnrunoff(sb,ii) / sub_fr(sb) - sub_hhsedy(sb,ii) = sub_hhsedy(sb,ii) / sub_fr(sb) - sub_ubntss(sb,ii) = sub_ubntss(sb,ii) / sub_fr(sb) - end do +! sub_subp(sb) = sub_subp(sb) / sub_fr(sb) +! sub_pet(sb) = sub_pet(sb) / sub_fr(sb) +! sub_etday(sb) = sub_etday(sb) / sub_fr(sb) +! + if (ievent >= 2) then +! + ! subdaily surface runoff, upland sediment for the subbasin + sub_ubnrunoff(sb,1:nstep) = sub_ubnrunoff(sb,1:nstep) + & / sub_fr(sb) + sub_ubntss(sb,1:nstep) = sub_ubntss(sb,1:nstep) / sub_fr(sb) + sub_hhqd(sb,1:nstep) = sub_hhqd(sb,1:nstep) / sub_fr(sb) + sub_hhsedy(sb,1:nstep) = sub_hhsedy(sb,1:nstep) + & / sub_fr(sb) + sub_atmp(sb,1:nstep) = sub_atmp(sb,1:nstep) / sub_fr(sb) + !---------------------------------------------------- ! Simulate distributed urban BMPs in the subbasin call distributed_bmps !---------------------------------------------------- - do ii = 1, nstep - !add urban runoff and non-urban runoff - sub_hhqd(sb,ii) = sub_hhqd(sb,ii) + sub_ubnrunoff(sb,ii) - sub_hhsedy(sb,ii) = sub_hhsedy(sb,ii) + sub_ubntss(sb,ii) - end do + !add urban runoff and non-urban runoff + sub_hhqd(sb,1:nstep) = sub_hhqd(sb,1:nstep) + & + sub_ubnrunoff(sb,1:nstep) + sub_hhsedy(sb,1:nstep) = sub_hhsedy(sb,1:nstep) + & + sub_ubntss(sb,1:nstep) + !route surface runoff in the subbasin - hqd = 0.; hsd = 0.; ii=0 !! added on Oct. 22, 2007 + hqd = 0.; hsd = 0. !! added on Oct. 22, 2007 do ii = 1, nstep do ib = 1, itb(sb) hqd(ib+ii-1) = hqd(ib+ii-1) + sub_hhqd(sb,ii) * uh(sb,ib) @@ -465,31 +478,28 @@ subroutine virtual hsd(ii) = hsd(ii) + hsdsave(sb,ii) end do - do ii = 1,nstep - sub_hhqd(sb,ii) = max(0.,hqd(ii)) - sub_hhsedy(sb,ii) = max(0.,hsd(ii)) - end do + sub_hhqd(sb,1:nstep) = max(0.,hqd(1:nstep)) + sub_hhsedy(sb,1:nstep) = max(0.,hsd(1:nstep)) do ii = 1, itb(sb) - ! hqdsave(ii) = hqdsave(ii+nstep) + hqd(ii+nstep) hqdsave(sb,ii) = hqd(ii+nstep) ! save flow after midnight for next day J.Jeong 4/17/2009 hsdsave(sb,ii) = hsd(ii+nstep) ! sediment. J.Jeong 4/22/2009 end do end if - sub_no3(sb) = sub_no3(sb) / sub_fr(sb) - sub_latno3(sb) = sub_latno3(sb) / sub_fr(sb) - sub_tileno3(sb) = sub_tileno3(sb) / sub_fr(sb) - sub_gwno3(sb) = sub_gwno3(sb) / sub_fr(sb) - sub_solp(sb) = sub_solp(sb) / sub_fr(sb) - sub_gwsolp(sb) = sub_gwsolp(sb) / sub_fr(sb) - sub_yorgn(sb) = sub_yorgn(sb) / sub_fr(sb) - sub_yorgp(sb) = sub_yorgp(sb) / sub_fr(sb) - sub_sedpa(sb) = sub_sedpa(sb) / sub_fr(sb) - sub_sedps(sb) = sub_sedps(sb) / sub_fr(sb) +! sub_no3(sb) = sub_no3(sb) / sub_fr(sb) +! sub_latno3(sb) = sub_latno3(sb) / sub_fr(sb) +! sub_tileno3(sb) = sub_tileno3(sb) / sub_fr(sb) +! sub_gwno3(sb) = sub_gwno3(sb) / sub_fr(sb) +! sub_solp(sb) = sub_solp(sb) / sub_fr(sb) +! sub_gwsolp(sb) = sub_gwsolp(sb) / sub_fr(sb) +! sub_yorgn(sb) = sub_yorgn(sb) / sub_fr(sb) +! sub_yorgp(sb) = sub_yorgp(sb) / sub_fr(sb) +! sub_sedpa(sb) = sub_sedpa(sb) / sub_fr(sb) +! sub_sedps(sb) = sub_sedps(sb) / sub_fr(sb) - sub_bactp(sb) = sub_bactp(sb) / sub_fr(sb) - sub_bactlp(sb) = sub_bactlp(sb) / sub_fr(sb) +! sub_bactp(sb) = sub_bactp(sb) / sub_fr(sb) +! sub_bactlp(sb) = sub_bactlp(sb) / sub_fr(sb) if (sub_wyld(sb) > 0.1) then sub_wtmp(sb) = sub_wtmp(sb) / sub_wyld(sb) @@ -497,16 +507,16 @@ subroutine virtual sub_wtmp(sb) = 0.0 end if - wcklsp(sb) = wcklsp(sb) / sub_fr(sb) - sub_precip(sb) = sub_precip(sb) / sub_fr(sb) - sub_surfq(sb) = sub_surfq(sb) / sub_fr(sb) - sub_tran(sb) = sub_tran(sb) / sub_fr(sb) - sub_bd(sb) = sub_bd(sb) / sub_fr(sb) - sub_orgn(sb) = sub_orgn(sb) / sub_fr(sb) - sub_orgp(sb) = sub_orgp(sb) / sub_fr(sb) - sub_minp(sb) = sub_minp(sb) / sub_fr(sb) - sub_minpa(sb) = sub_minpa(sb) / sub_fr(sb) - sub_minps(sb) = sub_minps(sb) / sub_fr(sb) +! wcklsp(sb) = wcklsp(sb) / sub_fr(sb) +! sub_precip(sb) = sub_precip(sb) / sub_fr(sb) +! sub_surfq(sb) = sub_surfq(sb) / sub_fr(sb) +! sub_tran(sb) = sub_tran(sb) / sub_fr(sb) +! sub_bd(sb) = sub_bd(sb) / sub_fr(sb) +! sub_orgn(sb) = sub_orgn(sb) / sub_fr(sb) +! sub_orgp(sb) = sub_orgp(sb) / sub_fr(sb) +! sub_minp(sb) = sub_minp(sb) / sub_fr(sb) +! sub_minpa(sb) = sub_minpa(sb) / sub_fr(sb) +! sub_minps(sb) = sub_minps(sb) / sub_fr(sb) !! assign reach loadings for subbasin @@ -541,17 +551,18 @@ subroutine virtual varoute(18,ihout) = sub_bactp(sb) * sub_ha / varoute(2,ihout) varoute(19,ihout) = sub_bactlp(sb) * sub_ha / varoute(2,ihout) end if - varoute(20,ihout) = 0. !! cmetal #1 - varoute(21,ihout) = 0. !! cmetal #2 - varoute(22,ihout) = 0. !! cmetal #3 - varoute(23,ihout) = sub_dsan(sb) !! detached sand - varoute(24,ihout) = sub_dsil(sb) !! detached silt - varoute(25,ihout) = sub_dcla(sb) !! detached clay - varoute(26,ihout) = sub_dsag(sb) !! detached sml ag - varoute(27,ihout) = sub_dlag(sb) !! detached lrg ag - varoute(29,ihout) = sub_qd(sb) !! surface runoff - varoute(30,ihout) = sub_latq(sb) !! lateral flow - varoute(32,ihout) = sub_gwq(sb) !! groundwater flow + varoute(20,ihout) = 0. !! cmetal #1 + varoute(21,ihout) = 0. !! cmetal #2 + varoute(22,ihout) = 0. !! cmetal #3 + varoute(23,ihout) = sub_dsan(sb) !! detached sand + varoute(24,ihout) = sub_dsil(sb) !! detached silt + varoute(25,ihout) = sub_dcla(sb) !! detached clay + varoute(26,ihout) = sub_dsag(sb) !! detached sml ag + varoute(27,ihout) = sub_dlag(sb) !! detached lrg ag + varoute(29,ihout) = sub_qd(sb) * sub_ha * 10. !! surface runoff + varoute(30,ihout) = sub_latq(sb) * sub_ha * 10. !! lateral flow + varoute(30,ihout) = sub_tileq(sb) * sub_ha * 10. !! tile flow + varoute(32,ihout) = sub_gwq(sb) * sub_ha * 10. !! groundwater flow !! varoute array has space for 33 different routing components !! sum variables for hyd.out @@ -562,27 +573,27 @@ subroutine virtual shyd(8,ihout) = shyd(8,ihout) + varoute(12,ihout) !! sub-daily calculations - if (ievent > 2) then + if (ievent >= 2) then !! determine the daily total base flow - baseflw = sub_gwq(sb) + sub_latq(sb) + baseflw = sub_gwq(sb) + sub_latq(sb) + sub_tileq(sb) if (baseflw < 0.) baseflw = 0. - !! assume water loadings other than surface runoff (eg groundwater, - !! lat Q and qtile) are evenly distributed over a day - sub_hwyld = 0. - ! Urban modeling by J.Jeong 4/23/2008 ! Daily water yield is unevenly distributed over time ! based on fractional rainfall of the day + sub_hwyld = 0. do ii = 1, nstep if(baseflw>0.1 .and. sum(precipdt)>0.1) then - bf_fr = bf_flg * precipdt(ii) / sum(precipdt) + + bf_fr = bf_flg * precipdt(ii+1) / sum(precipdt) + & (1. - bf_flg) * 1. / nstep sub_hwyld(ii) = sub_hhqd(sb,ii) + baseflw * bf_fr else sub_hwyld(ii) = sub_hhqd(sb,ii) + baseflw / nstep endif + !! water temperature, equation 2.3.13 in SWAT manual + sub_hhwtmp(sb,ii) = 5.0 + 0.75 * sub_atmp(sb,ii) + end do !! assign reach loadings for subbasin !! zero out hydrograph storage locations diff --git a/src/wetlan.f b/src/wetlan.f index 0150e63..3b875b0 100644 --- a/src/wetlan.f +++ b/src/wetlan.f @@ -142,6 +142,8 @@ subroutine wetlan real :: wetsani, wetsili, wetclai, wetsagi, wetlagi real :: san, sil, cla, sag, lag, inised, finsed,setsed,remsetsed real :: wetsano, wetsilo, wetclao, wetsago, wetlago + real :: qdayi, latqi + j = 0 j = ihru @@ -153,20 +155,18 @@ subroutine wetlan !! store initial values vol = 0. sed = 0. - - san = 0. - sil = 0. - cla = 0. - sag = 0. - lag = 0. - inised = 0. - finsed = 0. - setsed = 0. - remsetsed = 0. - + san = 0. + sil = 0. + cla = 0. + sag = 0. + lag = 0. + inised = 0. + finsed = 0. + setsed = 0. + remsetsed = 0. + vol = wet_vol(j) sed = wet_sed(j) - san = wet_san(j) sil = wet_sil(j) cla = wet_cla(j) @@ -182,8 +182,17 @@ subroutine wetlan wetpcp = subp(j) * wetsa * 10. !! calculate water flowing into wetland from HRU - wetflwi = qdr(j) * 10. * (hru_ha(j) * wet_fr(j) - wetsa) - qdr(j) = qdr(j) - qdr(j) * wet_fr(j) + wetflwi = qday + latq(j) + wetflwi = wetflwi * 10. * (hru_ha(j) * wet_fr(j) - wetsa) + qdayi = qday + latqi = latq(j) + qday = qday * (1. - wet_fr(j)) + latq(j) = latq(j) * (1. - wet_fr(j)) + wetloss = qdayi - qday + lwetloss = latqi - latq(j) + + qdr(j) = qdr(j) - wetloss - lwetloss +! qdr(j) = qdr(j) - qdr(j) * wet_fr(j) !! sediment loading to wetland from HRU wetsedi = sedyld(j) * (wet_fr(j) - (wetsa / hru_ha(j))) @@ -195,7 +204,6 @@ subroutine wetlan wetlagi = lagyld(j) * (wet_fr(j) - (wetsa / hru_ha(j))) sedyld(j) = sedyld(j) - sedyld(j) * wet_fr(j) - sanyld(j) = sanyld(j) - sanyld(j) * wet_fr(j) silyld(j) = silyld(j) - silyld(j) * wet_fr(j) clayld(j) = clayld(j) - clayld(j) * wet_fr(j) @@ -288,6 +296,7 @@ subroutine wetlan wet_vol(j) = wet_mxvol(j) end if end if + qday= qday + wetflwo / cnv qdr(j) = qdr(j) + wetflwo / cnv !! compute sediment settling diff --git a/src/wmeas.f b/src/wmeas.f index 0c044ab..67b6264 100644 --- a/src/wmeas.f +++ b/src/wmeas.f @@ -96,6 +96,8 @@ subroutine wmeas return - 5200 format (7x,300f8.3) - 5300 format (i4,i3,300f8.3) +! 5200 format (7x,300f8.3) +! 5300 format (i4,i3,300f8.3) + 5200 format (7x,1800f8.3) + 5300 format (i4,i3,1800f8.3) end diff --git a/src/writea.f b/src/writea.f index 1abe4dc..561e1c9 100644 --- a/src/writea.f +++ b/src/writea.f @@ -346,6 +346,6 @@ subroutine writea 5300 format (1x,i4,a4,1x,10f12.2,/) 5800 format ('RES ',i8,1x,i4,41e12.4) 6800 format ('RES ',i8,1x,i4,41e12.4,1x,i4) - 6300 format (/i5,15f7.2,1x,5f8.2//) + 6300 format (/i5,15f8.2,1x,5f8.2//) end diff --git a/src/writeaa.f b/src/writeaa.f index 161860b..cf9a1ef 100644 --- a/src/writeaa.f +++ b/src/writeaa.f @@ -415,8 +415,10 @@ subroutine writeaa wshd_tstrs = wshd_tstrs / yrs wshd_nstrs = wshd_nstrs / yrs wshd_pstrs = wshd_pstrs / yrs + wshd_astrs = wshd_astrs / yrs !! calculate watershed pothole averages spadyo = spadyo / yrs + spadyosp = spadyosp / yrs spadyev = spadyev / yrs spadysp = spadysp / yrs spadyrfv = spadyrfv / yrs @@ -461,12 +463,23 @@ subroutine writeaa sumorgn = sumorgn + sol_aorgn(ly,j) + sol_orgn(ly,j) + & sol_fon(ly,j) sumorgp = sumorgp + sol_fop(ly,j) + sol_orgp(ly,j) - else + end if + if (cswat == 1) then sumorgn = sumorgn + sol_orgn(ly,j) + sol_fon(ly,j) + & sol_mn(ly,j) sumorgp = sumorgp + sol_fop(ly,j) + sol_orgp(ly,j) + & sol_mp(ly,j) end if + !!add by zhang + !!======================= + if (cswat == 2) then + sumorgn = sumorgn + sol_LMN(ly,j) + sol_LSN(ly,j) + + & sol_HPN(ly,j) + sol_BMN(ly,j) + sol_HSN(ly,j) + sumorgp = sumorgp + sol_fop(ly,j) + sol_orgp(ly,j) + end if + !!add by zhang + !!======================= + summinp = summinp + sol_solp(ly,j) + sol_actp(ly,j) + & sol_stap(ly,j) end do @@ -516,14 +529,13 @@ subroutine writeaa end if !! write to hydrograph output file - idmm = 1 - do while (icodes(idmm) > 0) - ic = 0 + do idmm = 1, mhyd ic = ihouts(idmm) + if (ic > 0) then write(11123,9400) icodes(idmm), ic, inum1s(idmm), inum2s(idmm), & & inum3s(idmm),subed(ic),recmonps(ic),reccnstps(ic), & & (shyd(ii,ic), ii = 1, 8) - idmm = idmm + 1 + end if end do !! average septic outputs for output.std diff --git a/src/writed.f b/src/writed.f index 2e7ea2f..490d737 100644 --- a/src/writed.f +++ b/src/writed.f @@ -179,5 +179,6 @@ subroutine writed 5001 format(2i5,500f12.4) 5100 format(1x,a5,a4,1x,i4,1x,i3,1x,250(e16.4,1x)) 5200 format(i7,i9,i6,i5,1x,e9.4,f12.3,f7.1,f14.3) -6200 format(i5,13f7.2,2f5.2,1x,5f8.2) +!!6200 format(i5,13f7.2,2f5.2,1x,5f8.2) +6200 format(i5,15f8.2,1x,4f8.2) end diff --git a/src/writem.f b/src/writem.f index 94b67fe..e3a4ccb 100644 --- a/src/writem.f +++ b/src/writem.f @@ -403,6 +403,6 @@ subroutine writem 5300 format (1x,i4,a4,1x,10f12.2,/) 5800 format ('RES ',i8,1x,i4,41e12.4) 6800 format ('RES ',i8,1x,i4,41e12.4,1x,i4) - 6200 format (i5,15f7.2,1x,5f8.2) + 6200 format (i5,15f8.2,1x,4f8.2) end diff --git a/src/ysed.f b/src/ysed.f index aa52f39..8e96c48 100644 --- a/src/ysed.f +++ b/src/ysed.f @@ -72,27 +72,8 @@ subroutine ysed(iwave) !! subbasin sediment calculations cklsp(j) = wcklsp(iwave) else - !! HRU sediment calculations - if (icfac == 0) then - if (idplt(j) > 0) then - c = Exp((-.2231 - cvm(idplt(j))) * & - & Exp(-.00115 * sol_cov(j)) + cvm(idplt(j))) - else - if (sol_cov(j) > 1.e-4) then - c = Exp(-.2231 * Exp(-.00115 * sol_cov(j))) - else - c = .8 - end if - end if - else - rsd_frcov = Exp(-rsd_covco * sol_cov(j)) - grcov_fr = laiday(j) / (laiday(j) + - * Exp(1.748 - 1.748*laiday(j))) - bio_frcov = 1. - grcov_fr * Exp(-.01*cht(j)) - c = amax1(1.e-10,rsd_frcov*bio_frcov) - end if - - cklsp(j) = c * usle_mult(j) + !! HRU sediment calculations + cklsp(j) = usle_cfac(j) * usle_mult(j) end if !! compute sediment yield with musle diff --git a/src/zero0.f b/src/zero0.f index 9018541..db2904a 100644 --- a/src/zero0.f +++ b/src/zero0.f @@ -169,6 +169,7 @@ subroutine zero0 igrotree = 0 cvm = 0. daylmn = 0. + daru_km = 0. ! Drainmod tile equations 01/2006 dc = 0. drain_co_bsn = 0. @@ -254,6 +255,9 @@ subroutine zero0 gw_spyld = 0. gwht = 0. gwq_ru = 0. +! latq_ru = 0. +! surfq_ru = 0. +! infl_ru = 0. gwqmn = 0. ! Drainmod tile equations 01/2006 hdrain = 0. @@ -269,6 +273,7 @@ subroutine zero0 hru_fr = 0. hru_ha = 0. hru_km = 0. + hru_rufr = 0. hrugis = 0 hrupest = 0 hrupsta = 0. @@ -311,12 +316,20 @@ subroutine zero0 igro = 0 igrz = 0 ihouts = 0 + ils2 = 0 + ils2flag = 0 + ils_nofig = 0 inum1s = 0 inum2s = 0 inum3s = 0 inum4s = 0 + inum5s = 0 + inum6s = 0 + inum7s = 0 + inum8s = 1 iop = 0 ioper = 1 + iopera = 1 iopday = 0 iopyr = 0 ipdhru = 0 @@ -418,6 +431,8 @@ subroutine zero0 phubase = 0. pltnfr = 0. pltpfr = 0. + pot_seep = 0. + r2adj = 1. !! drainmod tile equations 06/2006 ranrns = 0. !! drainmod tile equations 06/2006 @@ -435,15 +450,15 @@ subroutine zero0 drydep_nh4_mo = 0. drydep_no3_mo = 0. !! routing 5/3/2010 gsm per jga - rutot = 0 idum = 0 mhyd1 = 0 irtun = 0 - - + ! Drainmod tile equations 01/2006 sdrain = 0. sdrain_bsn = 0. + sstmaxd = 0. + sstmaxd_bsn = 0. ! Drainmod tile equations 01/2006 rsr1 = 0. rsr2 = 0. @@ -479,14 +494,19 @@ subroutine zero0 subfr_nowtr = 0. sub_lat = 0. sub_latq = 0. + sub_tileq = 0. sub_latno3 = 0. sub_smtmp = 0. sub_tileno3 = 0. + sub_gwq_d = 0. + alpha_bf_d = 0. + gw_qdeep = 0. subgis = 0 tb_adj = 0. tdrain = 0. tdrain_bsn = 0. tile_no3 = 0. + tileq = 0. tile_ttime = 0. uh = 0. vfsratio = 0. diff --git a/src/zero1.f b/src/zero1.f index 33fda88..223770c 100644 --- a/src/zero1.f +++ b/src/zero1.f @@ -11,6 +11,34 @@ subroutine zero1 sol_mp = 0. sol_n = 0. +!! added by zhang for CSWAT == 2 + + sol_BMC = 0. + sol_BMN = 0. + sol_HSC = 0. + sol_HSN = 0. + sol_HPC = 0. + sol_HPN = 0. + sol_LM = 0. + sol_LMC = 0. + sol_LMN = 0. + sol_LS = 0. + sol_LSL = 0. + sol_LSC = 0. + sol_LSN = 0. + sol_RNMN = 0. + sol_LSLC = 0. + sol_LSLNC = 0. + sol_RSPC = 0. + sol_WOC = 0. + sol_WON = 0. + sol_HP = 0. + sol_HS = 0. + sol_BM = 0. +!! added by zhang for CSWAT == 2 + + + !! septic changes 6/07/10 jaehak bio_amn = 0. bio_bod = 0. @@ -167,6 +195,8 @@ subroutine zero1 pot_fr = 0. pot_no3 = 0. pot_no3l = 0. + pot_solpl = 0. + pot_k = -1. pot_nsed = 0. pot_sed = 0. @@ -325,6 +355,8 @@ subroutine zero1 trapeff = 0. urbcoef = 0. urbcn2 = 0. + usle_cfac = 0. + usle_eifac = 0. usle_k = 0. usle_ls = 0. usle_p = 0. diff --git a/src/zero2.f b/src/zero2.f index 8bf9bd9..d7569ce 100644 --- a/src/zero2.f +++ b/src/zero2.f @@ -193,6 +193,7 @@ subroutine zero2 pnd_solp = 0. pnd_solpg = 0. pot_volx = 0. + pot_volxmm = 0. potflwi = 0. potsedi = 0. potsani = 0. @@ -313,15 +314,6 @@ subroutine zero2 wurtnf = 0. yldn = 0. zdb = 0. - !! itelmon = 0 - !! variimon = 0. -!! itelyr = 0 -!! variiyr = 0. -!! itelmons = 0 -!! variimons = 0. -!! itelyrs = 0 -!! variiyrs = 0. - !! MJW sol_P_model = 0 diff --git a/src/zeroini.f b/src/zeroini.f index c206c50..604faa3 100644 --- a/src/zeroini.f +++ b/src/zeroini.f @@ -153,6 +153,7 @@ subroutine zeroini snocovmx = 0. spadyev = 0. spadyo = 0. + spadyosp = 0. spadyrfv = 0. spadysp = 0. spcon = 0. @@ -211,6 +212,7 @@ subroutine zeroini wshd_pndsed = 0. wshd_pndv = 0. wshd_pstrs = 0. + wshd_astrs = 0. wshd_pup = 0. wshd_raino3 = 0. wshd_resfr = 0.