diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 002b5bd..c83e611 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -9,6 +9,11 @@ on: - '*.*.*' workflow_dispatch: + inputs: + rev: + description: 'tag, branch, or SHA to check out' + required: true + default: 'develop' permissions: contents: write @@ -16,9 +21,38 @@ permissions: pull-requests: write jobs: + + version: + name: Version + runs-on: ubuntu-latest + steps: + - name: Checkout + uses: actions/checkout@v4 + with: + ref: '${{ github.event.inputs.rev }}' + fetch-tags: true + fetch-depth: 0 + - name: Get SWAT+ version + id: get_version + run: | + V=`git describe --tags` + echo $V + echo $V >v.txt + cat v.txt + echo ${{ github.event.release.tag_name }} + echo ${GITHUB_REF#refs/*/} + - name: upload + uses: actions/upload-artifact@v4 + with: + name: release_tag + path: v.txt + + build: runs-on: ${{ matrix.os }} - if: endsWith(github.event.base_ref, 'main') == true + needs: + - version + # if: endsWith(github.event.base_ref, 'main') == true strategy: fail-fast: false @@ -38,7 +72,8 @@ jobs: steps: - name: Checkout uses: actions/checkout@v4 - # with: + with: + ref: '${{ github.event.inputs.rev }}' # fetch-tags: true # fetch-depth: 0 @@ -49,13 +84,19 @@ jobs: compiler: ${{ matrix.toolchain.compiler }} version: ${{ matrix.toolchain.version }} + - name: Download version + uses: actions/download-artifact@v4 + with: + name: release_tag + - name: Build SWAT+ id: build_exe run: | echo ${{ env.FC }} cmake --version - RELEASE_VERSION=${GITHUB_REF#refs/*/} + # RELEASE_VERSION=${GITHUB_REF#refs/*/} + RELEASE_VERSION=`cat v.txt` os="$RUNNER_OS" if [ "$RUNNER_OS" == "Linux" ]; then @@ -83,7 +124,7 @@ jobs: fi # compile - cmake --build build + cmake --build build -j 4 exebase=`basename -s .exe build/swatplus-*` exez="${exebase}.zip" @@ -114,7 +155,7 @@ jobs: dest: ${{ steps.build_exe.outputs.exez }} - name: upload - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v4 with: name: sp-${{ steps.build_exe.outputs.os }} path: ${{ steps.build_exe.outputs.exez }} @@ -127,35 +168,48 @@ jobs: - build steps: - - name: Download Linux - uses: actions/download-artifact@v2 - with: - name: sp-Linux - - - name: Download Windows - uses: actions/download-artifact@v2 - with: - name: sp-Windows - - - name: Download macOS - uses: actions/download-artifact@v2 - with: - name: sp-macOS - - - name: Release - uses: softprops/action-gh-release@v2 - with: - token: ${{ github.token }} - tag_name: ${{ github.event.release.tag_name }} - prerelease: false - draft: false - name: ${{ github.event.release.tag_name }} - files: swatplus-* - generate_release_notes: true - body: | -
+ - name: Download Linux + uses: actions/download-artifact@v4 + with: + name: sp-Linux + + - name: Download Windows + uses: actions/download-artifact@v4 + with: + name: sp-Windows + + - name: Download macOS + uses: actions/download-artifact@v4 + with: + name: sp-macOS + + - name: Download version + uses: actions/download-artifact@v4 + with: + name: release_tag + + - name: Read version + id: read_ver + run: | + RELEASE_VERSION=`cat v.txt` + echo "rv=$RELEASE_VERSION" >> $GITHUB_OUTPUT + + - name: Release + uses: softprops/action-gh-release@v2 + if: startsWith(github.ref, 'refs/tags/') + with: + token: ${{ github.token }} + # tag_name: ${{ github.event.release.tag_name }} + prerelease: false + draft: false + # name: ${{ github.event.release.tag_name }} + name: ${{ steps.read_ver.outputs.rv }} + files: swatplus-* + generate_release_notes: true + body: | +
Autogenerated Changelog - ... changelog ... -
+ ... changelog ... +
diff --git a/.gitignore b/.gitignore index 7a2f2fd..4bfcb14 100644 --- a/.gitignore +++ b/.gitignore @@ -59,4 +59,5 @@ CMakeCache.txt Resources/R* src/main.f90 ford.md -/.vs/SWAT_PLUS_DEV \ No newline at end of file +/.vs/SWAT_PLUS_DEV +/.vscode diff --git a/CMakeLists.txt b/CMakeLists.txt index d3468e8..61e4692 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -33,19 +33,19 @@ if (UNIX) set(fdialect "-free -fpe0 -traceback -diag-disable=10448") set(fdebug "-warn all") set(frelease "-O") - set(FFC "ifo") + set(FFC "ifo") link_libraries("-static") elseif(CMAKE_Fortran_COMPILER_ID STREQUAL IntelLLVM) set(fdialect "-free -fpe0 -traceback") set(fdebug "-warn all -O0") set(frelease "-O") - set(FFC "ifx") + set(FFC "ifx") link_libraries("-static") elseif(CMAKE_Fortran_COMPILER_ID MATCHES GNU) - set(fdialect "-fcheck=all -ffpe-trap=invalid,zero,overflow,underflow -fimplicit-none -ffree-line-length-none -fbacktrace -finit-local-zero -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans") - set(fdebug "-Wall") - set(frelease "-O") - set(FFC "gcc") + set(fdialect "-fcheck=all -ffpe-trap=invalid,zero,overflow,underflow -fimplicit-none -ffree-line-length-none -fbacktrace -finit-local-zero -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans") + set(fdebug "-Wall") + set(frelease "-O") + set(FFC "gnu") if(NOT APPLE) link_libraries("-static") endif() @@ -66,18 +66,18 @@ elseif(WIN32) elseif(CMAKE_Fortran_COMPILER_ID MATCHES GNU) set(fdialect "-fcheck=all -ffpe-trap=invalid,zero,overflow,underflow -fimplicit-none -ffree-line-length-none -fbacktrace -finit-local-zero -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans") set(fdebug "-Wall ") - set(FFC "gcc") + set(FFC "gnu") set(frelease "-O") endif() endif() string(TOLOWER ${CMAKE_HOST_SYSTEM_PROCESSOR} ARCH) if(CMAKE_SYSTEM_NAME STREQUAL "Linux") - set(AR "${FFC}-lin_${ARCH}") + set(AR "lin_${ARCH}") elseif(CMAKE_SYSTEM_NAME STREQUAL "Windows") - set(AR "${FFC}-win_${ARCH}") + set(AR "win_${ARCH}") elseif(CMAKE_SYSTEM_NAME STREQUAL "Darwin") - set(AR "${FFC}-mac_${ARCH}") + set(AR "mac_${ARCH}") else() set(AR "unknown") endif() @@ -92,9 +92,9 @@ endif() # SWAT Version number set(SWAT_VERSION ${TAG}) -set(SWATPLUS_EXE "swatplus-${SWAT_VERSION}-${AR}${TY}") +set(SWATPLUS_EXE "swatplus-${SWAT_VERSION}-${FFC}-${AR}${TY}") -# Enable this to 'TRUE' to see the fortran command on compile +# Set this to 'TRUE' to see the fortran command on compile set(CMAKE_VERBOSE_MAKEFILE FALSE) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${fdialect}") @@ -111,7 +111,6 @@ set(CMAKE_Fortran_FLAGS_RELEASE "${frelease}") if(EXISTS "${PROJECT_SOURCE_DIR}/src/main.f90.in") string(TIMESTAMP ISO "%Y-%m-%d %H:%M:%S") - # string(TIMESTAMP TODAY "%b %d %Y") # e.g. produces Dec 7 2023 string(TIMESTAMP TODAY "%Y-%m-%d") # e.g. produces 2023-12-07 string(TIMESTAMP YEAR "%Y") diff --git a/src/actions.f90 b/src/actions.f90 index b13ae15..cd48f9b 100644 --- a/src/actions.f90 +++ b/src/actions.f90 @@ -71,6 +71,8 @@ subroutine actions (ob_cur, ob_num, idtbl) integer :: imallo = 0 integer :: idmd = 0 integer :: irec = 0 + integer :: iplt = 0 + integer :: num_plts_cur = 0 real :: hiad1 = 0. ! | real :: biomass = 0. ! | real :: frt_kg = 0. @@ -88,7 +90,7 @@ subroutine actions (ob_cur, ob_num, idtbl) real :: cn_prev = 0. real :: stor_m3 = 0. character(len=1) :: action = "" ! | - character(len=25) :: lu_prev = "" ! | + character(len=40) :: lu_prev = "" ! | do iac = 1, d_tbl%acts action = "n" @@ -398,12 +400,13 @@ subroutine actions (ob_cur, ob_num, idtbl) harveff = d_tbl%act(iac)%const call mgt_harvresidue (j, harveff) case ("tree") + call mgt_harvbiomass (j, ipl, iharvop) case ("tuber") call mgt_harvtuber (j, ipl, iharvop) case ("peanuts") call mgt_harvtuber (j, ipl, iharvop) case ("stripper") - call mgt_harvgrain (j, ipl, iharvop) + call mgt_harvbiomass (j, ipl, iharvop) case ("picker") call mgt_harvgrain (j, ipl, iharvop) end select @@ -886,7 +889,10 @@ subroutine actions (ob_cur, ob_num, idtbl) case ("lu_change") j = d_tbl%act(iac)%ob_num if (j == 0) j = ob_cur + if (d_tbl%lu_chg_mx(iac) <= Int(d_tbl%act(iac)%const2)) then + d_tbl%lu_chg_mx(iac) = d_tbl%lu_chg_mx(iac) + 1 ilu = d_tbl%act_typ(iac) + hru(j)%land_use_mgt = ilu hru(j)%dbs%land_use_mgt = ilu lu_prev = hru(j)%land_use_mgt_c hru(j)%land_use_mgt_c = d_tbl%act(iac)%file_pointer @@ -902,6 +908,27 @@ subroutine actions (ob_cur, ob_num, idtbl) write (3612,*) j, time%yrc, time%mo, time%day_mo, " LU_CHANGE ", & lu_prev, hru(j)%land_use_mgt_c, " 0 0" + !! add new plants in simulation for yield output + do ipl = 1, pcom(j)%npl + if (basin_plants == 0) then + plts_bsn(1) = pcom(j)%pl(ipl) + basin_plants = 1 + else + num_plts_cur = basin_plants + do iplt = 1, num_plts_cur + if (pcom(j)%pl(ipl) == plts_bsn(iplt)) exit + if (iplt == basin_plants) then + plts_bsn(iplt+1) = pcom(j)%pl(ipl) + bsn_crop_yld(iplt+1) = bsn_crop_yld_z + bsn_crop_yld_aa(iplt+1) = bsn_crop_yld_z + basin_plants = basin_plants + 1 + pcom(j)%plcur(ipl)%bsn_num = basin_plants + end if + end do + end if + end do + !pcom(j)%dtbl(idtbl)%num_actions(iac) = pcom(j)%dtbl(idtbl)%num_actions(iac) + 1 + end if !land use change - contouring case ("p_factor") j = d_tbl%act(iac)%ob_num @@ -1033,7 +1060,8 @@ subroutine actions (ob_cur, ob_num, idtbl) do istr = 1, db_mx%grassop_db if (d_tbl%act(iac)%file_pointer == grwaterway_db(istr)%name) then - istr1 = istr + !istr1 = istr + hru(j)%lumv%grwat_i = 1 exit end if end do @@ -1045,6 +1073,13 @@ subroutine actions (ob_cur, ob_num, idtbl) write (3612,*) j, time%yrc, time%mo, time%day_mo, " GRASSWW_INSTALL ", & sdr(istr)%name, sdr(istr1)%name, " 0 0" + !install grass waterways + case ("grassww_uninstall") + j = d_tbl%act(iac)%ob_num + if (j == 0) j = ob_cur + hru(j)%lumv%grwat_i = 0 + write (3612,*) j, time%yrc, time%mo, time%day_mo, " GRASSWW_UNINSTALL ", & + sdr(istr)%name, sdr(istr1)%name, " 0 0" !user defined bmp reductions case ("user_def_bmp") j = d_tbl%act(iac)%ob_num diff --git a/src/allocate_parms.f90 b/src/allocate_parms.f90 index c4f2f39..471ae33 100644 --- a/src/allocate_parms.f90 +++ b/src/allocate_parms.f90 @@ -213,7 +213,7 @@ subroutine allocate_parms !! By Zhang for C/N cycling !! ============================ - + call zero0 call zero1 call zero2 diff --git a/src/aqu_cs_output.f90 b/src/aqu_cs_output.f90 index 3c72527..12035db 100644 --- a/src/aqu_cs_output.f90 +++ b/src/aqu_cs_output.f90 @@ -49,7 +49,7 @@ subroutine aqu_cs_output(iaq) !rtb cs (acsb_d(iaq)%cs(ics)%srbd,ics=1,cs_db%num_cs) if (pco%csvout == "y") then write (6061,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iaq, ob(iob)%gis_id, & - (acsb_d(iaq)%cs(ics)%csgw,ics=1,cs_db%num_cs), & + (acsb_d(iaq)%cs(ics)%csgw,ics=1,cs_db%num_cs), & (acsb_d(iaq)%cs(ics)%rchrg,ics=1,cs_db%num_cs), & (acsb_d(iaq)%cs(ics)%seep,ics=1,cs_db%num_cs), & (acsb_d(iaq)%cs(ics)%irr,ics=1,cs_db%num_cs), & diff --git a/src/aqu_salt_output.f90 b/src/aqu_salt_output.f90 index fdef427..70ca55d 100644 --- a/src/aqu_salt_output.f90 +++ b/src/aqu_salt_output.f90 @@ -44,7 +44,7 @@ subroutine aqu_salt_output(iaq) asaltb_d(iaq)%salt(1)%diss if (pco%csvout == "y") then write (5061,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iaq, ob(iob)%gis_id, & - (asaltb_d(iaq)%salt(isalt)%saltgw,isalt=1,cs_db%num_salts), & + (asaltb_d(iaq)%salt(isalt)%saltgw,isalt=1,cs_db%num_salts), & (asaltb_d(iaq)%salt(isalt)%rchrg,isalt=1,cs_db%num_salts), & (asaltb_d(iaq)%salt(isalt)%seep,isalt=1,cs_db%num_salts), & (asaltb_d(iaq)%salt(isalt)%irr,isalt=1,cs_db%num_salts), & diff --git a/src/basin_module.f90 b/src/basin_module.f90 index f7fa599..47a0498 100644 --- a/src/basin_module.f90 +++ b/src/basin_module.f90 @@ -21,32 +21,24 @@ module basin_module !! 0 = Priestley-Taylor !! 1 = Penman-Monteith !! 2 = Hargreaves method - !! 3 = read in daily pot ET values - integer :: event = 0 !! event code + integer :: event = 0 !! not used integer :: crk = 0 !! crack flow code !! 1 = compute flow in cracks integer :: swift_out = 0 !! write to SWIFT input file !! 0 = do not write !! 1 = write to swift_hru.inp - integer :: sed_det = 0 !! max half-hour rainfall frac calc - !! 0 = gen from triangular dist - !! 1 = use monthly mean frac + integer :: sed_det = 0 !! not used integer :: rte = 0 !! water routing method !! 0 variable storage method !! 1 Muskingum method - integer :: deg = 0 !! channel degradation code - !! 0 = do not compute - !! 1 = compute (downcutting and widening) - integer :: wq = 0 !! stream water quality code - !! 0 do not model - !! 1 model (QUAL2E) + integer :: deg = 0 !! not used + integer :: wq = 0 !! not used integer :: nostress = 0 !! redefined to the sequence number -- changed to no nutrient stress !! 0 = all stresses applied !! 1 = turn off all plant stress !! 2 = turn off nutrient plant stress only integer :: cn = 0 !! not used - integer :: cfac = 0 !! 0 = C-factor calc using CMIN - !! 1 = for new C-factor from RUSLE (no min needed) + integer :: cfac = 0 !! not used integer :: cswat = 0 !! carbon code !! = 0 Static soil carbon (old mineralization routines) !! = 1 C-FARM one carbon pool model @@ -57,29 +49,20 @@ module basin_module integer :: uhyd = 1 !! Unit hydrograph method: !! 0 = triangular UH !! 1 = gamma function UH - integer :: sed_ch = 0 !! Instream sediment model - !! 0 = Bagnold model - !! 1 = Brownlie model - !! 2 = Yang model + integer :: sed_ch = 0 !! not used integer :: tdrn = 0 !! tile drainage eq code - !! 1 = sim tile flow using subsurface drains (wt_shall) - !! 0 = sim tile flow using subsurface origtile (wt_shall,d) - integer :: wtdn = 0 !! water table depth algorithms code - !! 1 = sim wt_shall using subsurface new water table depth routine - !! 0 = sim wt_shall using subsurface orig water table depth routine - integer :: sol_p_model=0 !! 1 = new soil P model + !! 0 = tile flow using drawdown days equation + !! 1 = tile flow using drainmod equations + integer :: wtdn = 0 !! shallow water table depth algorithms code + !! 0 = depth using orig water table depth routine - fill to upper limit + !! 1 = depth using drainmod water table depth routine + integer :: sol_p_model=0 !! 0 = original soil P model in SWAT documentation + !! 1 = new soil P model in Vadas and White (2010) integer :: gampt = 0 !! 0 = curve number; 1 = Green and Ampt - character(len=1) :: atmo = "a" !! atmospheric deposition interval - !! "m" = monthly - !! "y" = yearly - !! "a" = annual - integer :: smax = 0 !! max depressional storage selection code - !! 1 = dynamic stmaxd computed as a cunfction of random - !! roughness and rain intensity - !! 0 = static stmaxd read from .bsn for the global value or .sdr - !! for specific hrus - integer :: qual2e = 0 !! 0 = channel routine using QUAL2E - !! 1 = channel routing with simplified nutrient transformations + character(len=1) :: atmo = "a" !! not used + integer :: smax = 0 !! not used + integer :: qual2e = 0 !! 0 = instream nutrient routing using QUAL2E + !! 1 = instream nutrient routing using QUAL2E - with simplified nutrient transformations integer :: gwflow = 0 !! 0 = gwflow module not active; 1 = gwflow module active end type basin_control_codes type (basin_control_codes) :: bsn_cc @@ -396,11 +379,11 @@ module basin_module ! type(snutc_old_header) :: snutc_old_hdr type basin_yld_header - character (len=10) :: year = " year " + character (len=11) :: year = " year " character (len=16) :: plant_no = " plant_no" character (len=16) :: plant_name = "plant_name " - character (len=16) :: area_ha = " harv_area(ha) " - character (len=16) :: yield_t = " yld(t) " + character (len=17) :: area_ha = " harv_area(ha) " + character (len=17) :: yield_t = " yld(t) " character (len=16) :: yield_tha = " yld(t/ha) " end type basin_yld_header type (basin_yld_header) :: bsn_yld_hdr diff --git a/src/cal_conditions.f90 b/src/cal_conditions.f90 index 0f503f8..0e1a9e4 100644 --- a/src/cal_conditions.f90 +++ b/src/cal_conditions.f90 @@ -12,7 +12,7 @@ subroutine cal_conditions implicit none - character(len=16) :: chg_parm = "" ! | + character(len=25) :: chg_parm = "" ! | character(len=16) :: chg_typ = "" !variable |type of change (absval, abschg, pctchg) character(len=1) :: cond_met = "" ! | character(len=1) :: pl_find = "" ! | @@ -79,13 +79,8 @@ subroutine cal_conditions cond_met = "n" exit end if - case ("region") !for hru - if (cal_upd(ichg_par)%cond(ic)%targc /= hru(ielem)%region) then - cond_met = "n" - exit - end if - case ("region_lte") !for hru - if (cal_upd(ichg_par)%cond(ic)%targc /= hru(ielem)%region) then + case ("cal_group") !for hru + if (cal_upd(ichg_par)%cond(ic)%targc /= hru(ielem)%cal_group) then cond_met = "n" exit end if diff --git a/src/cal_parm_select.f90 b/src/cal_parm_select.f90 index 75ac6c3..43ac894 100644 --- a/src/cal_parm_select.f90 +++ b/src/cal_parm_select.f90 @@ -34,7 +34,7 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma use hydrograph_module use pesticide_data_module use plant_module - use gwflow_module + use gwflow_module implicit none @@ -438,6 +438,9 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma chg_typ, chg_val, absmin, absmax) !! SWQ + case ("mumax") + ch_nut(ielem)%mumax = chg_par(ch_nut(ielem)%mumax, & + chg_typ, chg_val, absmin, absmax) case ("rs1") ch_nut(ielem)%rs1 = chg_par(ch_nut(ielem)%rs1, & chg_typ, chg_val, absmin, absmax) @@ -611,20 +614,16 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma sd_ch(ielem)%chk = chg_par(sd_ch(ielem)%chk, & chg_typ, chg_val, absmin, absmax) - case ("cherod") - sd_ch(ielem)%cherod = chg_par(sd_ch(ielem)%cherod, & + case ("bank_exp") + sd_ch(ielem)%bank_exp = chg_par(sd_ch(ielem)%bank_exp, & chg_typ, chg_val, absmin, absmax) case ("cov") sd_ch(ielem)%cov = chg_par(sd_ch(ielem)%cov, & chg_typ, chg_val, absmin, absmax) - ! case ("wd_rto") - ! sd_ch(ielem)%wd_rto = chg_par(sd_ch(ielem)%wd_rto, & - ! chg_typ, chg_val, absmin, absmax) - - case ("flood_sedfrac") - sd_ch(ielem)%chseq = chg_par(sd_ch(ielem)%chseq, & + case ("vcr_coef") + sd_ch(ielem)%vcr_coef = chg_par(sd_ch(ielem)%vcr_coef, & chg_typ, chg_val, absmin, absmax) case ("d50") @@ -712,8 +711,8 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma sd_ch(ielem)%arc_len_fr = chg_par(sd_ch(ielem)%arc_len_fr, & chg_typ, chg_val, absmin, absmax) - case ("part_size") - sd_ch(ielem)%part_size = chg_par(sd_ch(ielem)%part_size, & + case ("bed_exp") + sd_ch(ielem)%bed_exp = chg_par(sd_ch(ielem)%bed_exp, & chg_typ, chg_val, absmin, absmax) case ("wash_bed_fr") @@ -740,6 +739,11 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma case ("nsed") res_prm(ielem)%sed%nsed = chg_par(res_prm(ielem)%sed%nsed, & chg_typ, chg_val, absmin, absmax) + case ("res_d50") + res_prm(ielem)%sed%d50 = chg_par(res_prm(ielem)%sed%d50, & + chg_typ, chg_val, absmin, absmax) + !! d50 -micro meters + res_prm(ielem)%sed_stlr_co = exp(-0.184 * res_prm(ielem)%sed%d50) case ("sed_stlr") res_prm(ielem)%sed%sed_stlr = chg_par(res_prm(ielem)%sed%sed_stlr, & @@ -952,45 +956,45 @@ subroutine cal_parm_select (ielem, ly, chg_parm, chg_typ, chg_val, absmin, absma hlt_db(ielem)%uslels = chg_par (hlt_db(ielem)%uslels, chg_typ, chg_val, absmin, absmax) - !!gwflow (rtb) + !!gwflow (rtb) case ("aquifer_K") - if(bsn_cc%gwflow.eq.1) then - gw_state(ielem)%hydc = chg_par(gw_state(ielem)%hydc, chg_typ, chg_val, absmin, absmax) - endif - - case ("aquifer_Sy") - if(bsn_cc%gwflow.eq.1) then - gw_state(ielem)%spyd = chg_par(gw_state(ielem)%spyd, chg_typ, chg_val, absmin, absmax) - endif - - case ("aquifer_delay") - if(bsn_cc%gwflow.eq.1) then - gw_delay(ielem) = chg_par(gw_delay(ielem), chg_typ, chg_val, absmin, absmax) + if(bsn_cc%gwflow.eq.1) then + gw_state(ielem)%hydc = chg_par(gw_state(ielem)%hydc, chg_typ, chg_val, absmin, absmax) + endif + + case ("aquifer_Sy") + if(bsn_cc%gwflow.eq.1) then + gw_state(ielem)%spyd = chg_par(gw_state(ielem)%spyd, chg_typ, chg_val, absmin, absmax) + endif + + case ("aquifer_delay") + if(bsn_cc%gwflow.eq.1) then + gw_delay(ielem) = chg_par(gw_delay(ielem), chg_typ, chg_val, absmin, absmax) endif - - case ("aquifer_exdp") - if(bsn_cc%gwflow.eq.1) then - gw_state(ielem)%exdp = chg_par(gw_state(ielem)%exdp, chg_typ, chg_val, absmin, absmax) - endif - - case ("stream_K") - if(bsn_cc%gwflow.eq.1) then - do icell=1,gw_chan_info(ielem)%ncon !loop through cells connected to channel - gw_chan_info(ielem)%hydc(icell) = chg_par(gw_chan_info(ielem)%hydc(icell), chg_typ, chg_val, absmin, absmax) - enddo - endif - - case ("stream_thk") - if(bsn_cc%gwflow.eq.1) then - do icell=1,gw_chan_info(ielem)%ncon !loop through cells connected to channel - gw_chan_info(ielem)%thck(icell) = chg_par(gw_chan_info(ielem)%thck(icell), chg_typ, chg_val, absmin, absmax) - enddo - endif - - case ("stream_bed") - if(bsn_cc%gwflow.eq.1) then - gw_bed_change = chg_par(gw_bed_change, chg_typ, chg_val, absmin, absmax) - endif + + case ("aquifer_exdp") + if(bsn_cc%gwflow.eq.1) then + gw_state(ielem)%exdp = chg_par(gw_state(ielem)%exdp, chg_typ, chg_val, absmin, absmax) + endif + + case ("stream_K") + if(bsn_cc%gwflow.eq.1) then + do icell=1,gw_chan_info(ielem)%ncon !loop through cells connected to channel + gw_chan_info(ielem)%hydc(icell) = chg_par(gw_chan_info(ielem)%hydc(icell), chg_typ, chg_val, absmin, absmax) + enddo + endif + + case ("stream_thk") + if(bsn_cc%gwflow.eq.1) then + do icell=1,gw_chan_info(ielem)%ncon !loop through cells connected to channel + gw_chan_info(ielem)%thck(icell) = chg_par(gw_chan_info(ielem)%thck(icell), chg_typ, chg_val, absmin, absmax) + enddo + endif + + case ("stream_bed") + if(bsn_cc%gwflow.eq.1) then + gw_bed_change = chg_par(gw_bed_change, chg_typ, chg_val, absmin, absmax) + endif !! initial soil properties case ("lab_p") diff --git a/src/cal_parmchg_read.f90 b/src/cal_parmchg_read.f90 index 8e46356..aa96f53 100644 --- a/src/cal_parmchg_read.f90 +++ b/src/cal_parmchg_read.f90 @@ -128,9 +128,9 @@ subroutine cal_parmchg_read cal_upd(i)%num_elem = db_mx%pcpfiles case ("tmp") cal_upd(i)%num_elem = db_mx%tmpfiles - case ("gwf") !rtb - all gwflow cells - cal_upd(i)%num_elem = ncell - case ("gwf_riv") !rtb - all channels + case ("gwf") !rtb - all gwflow cells + cal_upd(i)%num_elem = ncell + case ("gwf_riv") !rtb - all channels cal_upd(i)%num_elem = sp_ob%chandeg case ("gwf_sgl") !rtb - single value cal_upd(i)%num_elem = 1 diff --git a/src/calsoft_chsed.f90 b/src/calsoft_chsed.f90 deleted file mode 100644 index 7524c2c..0000000 --- a/src/calsoft_chsed.f90 +++ /dev/null @@ -1,520 +0,0 @@ - subroutine calsoft_chsed - - use hydrograph_module - use ru_module - use aquifer_module - use channel_module - use hru_lte_module - use sd_channel_module - use basin_module - use maximum_data_module - use calibration_data_module - use conditional_module - use reservoir_module - use organic_mineral_mass_module - - implicit none - - integer :: ical_sed = 0 ! | - integer :: iter_all = 0 ! |end of loop - integer :: iterall = 0 !none |counter - integer :: isim = 0 ! | - integer :: ireg = 0 !none |counter - integer :: iord = 0 !none |counter - real :: soft = 0. ! | - real :: diff = 0. ! | - real :: chg_val = 0. ! | - integer :: ich_s = 0 !none |counter - integer :: iich = 0 ! | - integer :: icov = 0 !none |counter - real :: rmeas = 0. ! | - real :: denom = 0. ! | - integer :: iter_ind = 0 ! |end of loop - integer :: ierod = 0 !none |counter - - - !calibrate sediment - ical_sed = 0 - - !calibrate hydrology - ical_sed = 0 - iter_all = 1 - iter_ind = 1 - - do iterall = 1, iter_all - ! 1st cover adjustment for channel widening - isim = 0 - do ireg = 1, db_mx%ch_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chw - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%erod < 1.e-6) then - isim = 1 - - chcal(ireg)%ord(iord)%prm_prev = chcal(ireg)%ord(iord)%prm - chcal(ireg)%ord(iord)%prev = chcal(ireg)%ord(iord)%aa - - if (soft < chcal(ireg)%ord(iord)%aa%chw) then - chg_val = 1. / (abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) + 1.05) - else - chg_val = abs((chcal(ireg)%ord(iord)%aa%chw - soft) / chcal(ireg)%ord(iord)%aa%chw) + 1.05 - end if - chcal(ireg)%ord(iord)%prm_prev%erod = chcal(ireg)%ord(iord)%prm%erod - chcal(ireg)%ord(iord)%prm%erod = chg_val - chcal(ireg)%ord(iord)%prev%chw = chcal(ireg)%ord(iord)%aa%chw - - if (chcal(ireg)%ord(iord)%prm%erod >= ch_prms(1)%pos) then - chg_val = ch_prms(1)%pos - chcal(ireg)%ord(iord)%prm%erod = ch_prms(1)%pos - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%erod <= ch_prms(1)%neg) then - chg_val = ch_prms(1)%neg - chcal(ireg)%ord(iord)%prm%erod = ch_prms(1)%neg - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for 1st width calibration and rerun - sd_ch(iich)%cherod = sd_ch(iich)%cherod * chg_val - sd_ch(iich)%cherod = amin1 (sd_ch(iich)%cherod, ch_prms(1)%up) - sd_ch(iich)%cherod = Max (sd_ch(iich)%cherod, ch_prms(1)%lo) - sdch_init(iich)%cherod = sd_ch(iich)%cherod - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! 1st cover adjustment - if (isim > 0) then - cal_sim = " first chan erod adj " - cal_adj = chg_val - call time_control - end if - - ! cover adjustment for channel widening - do icov = 1, iter_ind - isim = 0 - do ireg = 1, db_mx%ch_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chw - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%erod < 1.e-6) then - isim = 1 - - chcal(ireg)%ord(iord)%prm_prev = chcal(ireg)%ord(iord)%prm - chcal(ireg)%ord(iord)%prev = chcal(ireg)%ord(iord)%aa - - if (soft < chcal(ireg)%ord(iord)%aa%chw) then - chg_val = 1. / (abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) + 1.05) - else - chg_val = abs((chcal(ireg)%ord(iord)%aa%chw - soft) / chcal(ireg)%ord(iord)%aa%chw) + 1.05 - end if - chcal(ireg)%ord(iord)%prm_prev%erod = chcal(ireg)%ord(iord)%prm%erod - chcal(ireg)%ord(iord)%prm%erod = chcal(ireg)%ord(iord)%prm%erod * chg_val - chcal(ireg)%ord(iord)%prev%chw = chcal(ireg)%ord(iord)%aa%chw - - if (chcal(ireg)%ord(iord)%prm%erod >= ch_prms(1)%pos) then - chg_val = ch_prms(1)%pos - chcal(ireg)%ord(iord)%prm%erod = ch_prms(1)%pos - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%erod <= ch_prms(1)%neg) then - chg_val = ch_prms(1)%neg - chcal(ireg)%ord(iord)%prm%erod = ch_prms(1)%neg - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for width calibration and rerun - sd_ch(iich)%cherod = sd_ch(iich)%cherod * chg_val - sd_ch(iich)%cherod = amin1 (sd_ch(iich)%cherod, ch_prms(1)%up) - sd_ch(iich)%cherod = Max (sd_ch(iich)%cherod, ch_prms(1)%lo) - sdch_init(iich)%cherod = sd_ch(iich)%cherod - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! cover adjustment - if (isim > 0) then - cal_sim = " chan erodibility adj " - cal_adj = chg_val - call time_control - end if - end do ! icov - - !! finish - but leave code in case i need to add back - go to 777 - - - ! 1st bank shear coefficient adjustment for channel widening - isim = 0 - do ireg = 1, db_mx%ch_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chw - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%shear_bnk < 1.e-6) then - isim = 1 - - chcal(ireg)%ord(iord)%prm_prev = chcal(ireg)%ord(iord)%prm - chcal(ireg)%ord(iord)%prev = chcal(ireg)%ord(iord)%aa - - chg_val = chcal(ireg)%ord(iord)%meas%chw / (chcal(ireg)%ord(iord)%aa%chw + 1.e-6) !assume same ratio of cover and width change - chcal(ireg)%ord(iord)%prm_prev%shear_bnk = chcal(ireg)%ord(iord)%prm%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk = chcal(ireg)%ord(iord)%prm%shear_bnk + chg_val - chcal(ireg)%ord(iord)%prev%chw = chcal(ireg)%ord(iord)%aa%chw - - if (chcal(ireg)%ord(iord)%prm%shear_bnk >= ch_prms(3)%pos) then - chg_val = ch_prms(3)%pos - chcal(ireg)%ord(iord)%prm_prev%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk = ch_prms(3)%pos - chcal(ireg)%ord(iord)%prm_lim%shear_bnk = 1. - end if - if (chcal(ireg)%ord(iord)%prm%shear_bnk <= ch_prms(3)%neg) then - chg_val = ch_prms(3)%neg - chcal(ireg)%ord(iord)%prm_prev%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk = ch_prms(3)%neg - chcal(ireg)%ord(iord)%prm_lim%shear_bnk = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for 1st width calibration and rerun - sdch_init(iich)%shear_bnk = sdch_init(iich)%shear_bnk + chg_val - sdch_init(iich)%shear_bnk = amin1 (sdch_init(iich)%shear_bnk, ch_prms(3)%up) - sdch_init(iich)%shear_bnk = Max (sdch_init(iich)%shear_bnk, ch_prms(3)%lo) - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! 1st bank shear coefficient adjustment - if (isim > 0) then - write (4601,*) " first bank shear coeff adj " - call time_control - end if - - ! bank shear coefficient adjustment for channel widening - do icov = 1, iter_ind - isim = 0 - do ireg = 1, db_mx%cha_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chw - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chw) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%shear_bnk < 1.e-6) then - isim = 1 - - rmeas = chcal(ireg)%ord(iord)%meas%chw - denom = chcal(ireg)%ord(iord)%prev%chw - chcal(ireg)%ord(iord)%aa%chw - if (abs(denom) > 1.e-6) then - chg_val = - (chcal(ireg)%ord(iord)%prm_prev%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk) & - * (chcal(ireg)%ord(iord)%aa%chw - rmeas) / denom - else - chg_val = chcal(ireg)%ord(iord)%meas%chw / chcal(ireg)%ord(iord)%aa%chw - end if - chcal(ireg)%ord(iord)%prm_prev%shear_bnk = chcal(ireg)%ord(iord)%prm%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk = chcal(ireg)%ord(iord)%prm%shear_bnk + chg_val - chcal(ireg)%ord(iord)%prev%chw = chcal(ireg)%ord(iord)%aa%chw - - if (chcal(ireg)%ord(iord)%prm%shear_bnk >= ch_prms(3)%pos) then - chg_val = ch_prms(3)%pos - chcal(ireg)%ord(iord)%prm_prev%shear_bnk - chcal(ireg)%ord(iord)%prm%shear_bnk = ch_prms(3)%pos - chcal(ireg)%ord(iord)%prm_lim%shear_bnk = 1. - end if - if (chcal(ireg)%ord(iord)%prm%shear_bnk <= ch_prms(3)%neg) then - chg_val = chcal(ireg)%ord(iord)%prm_prev%shear_bnk - ch_prms(3)%neg - chcal(ireg)%ord(iord)%prm%shear_bnk = ch_prms(3)%neg - chcal(ireg)%ord(iord)%prm_lim%shear_bnk = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for width calibration and rerun - sdch_init(iich)%shear_bnk = sdch_init(iich)%shear_bnk + chg_val - sdch_init(iich)%shear_bnk = amin1 (sdch_init(iich)%shear_bnk, ch_prms(3)%up) - sdch_init(iich)%shear_bnk = Max (sdch_init(iich)%shear_bnk, ch_prms(3)%lo) - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! bank shear coefficient adjustment - if (isim > 0) then - write (4601,*) " bank shear coeff adj " - call time_control - end if - end do ! icov - - ! 1st erodibility adjustment for channel downcutting - isim = 0 - do ireg = 1, db_mx%ch_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chd - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chd) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%erod < 1.e-6) then - isim = 1 - - chcal(ireg)%ord(iord)%prm_prev = chcal(ireg)%ord(iord)%prm - chcal(ireg)%ord(iord)%prev = chcal(ireg)%ord(iord)%aa - - chg_val = chcal(ireg)%ord(iord)%meas%chd / (chcal(ireg)%ord(iord)%aa%chd + 1.e-6) !assume same ratio of cover and width change - chcal(ireg)%ord(iord)%prm_prev%erod = chcal(ireg)%ord(iord)%prm%erod - chcal(ireg)%ord(iord)%prm%erod = chcal(ireg)%ord(iord)%prm%erod + chg_val - chcal(ireg)%ord(iord)%prev%chd = chcal(ireg)%ord(iord)%aa%chd - - if (chcal(ireg)%ord(iord)%prm%erod >= ch_prms(2)%pos) then - chg_val = ch_prms(2)%pos - chcal(ireg)%ord(iord)%prm_prev%erod - chcal(ireg)%ord(iord)%prm%erod = ch_prms(2)%pos - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%erod <= ch_prms(2)%neg) then - chg_val = ch_prms(2)%neg - chcal(ireg)%ord(iord)%prm_prev%erod - chcal(ireg)%ord(iord)%prm%erod = ch_prms(2)%neg - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for 1st erodibility calibration and rerun - sdch_init(iich)%cherod = sdch_init(iich)%cherod / chg_val - sdch_init(iich)%cherod = amin1 (sdch_init(iich)%cherod, ch_prms(2)%up) - sdch_init(iich)%cherod = Max (sdch_init(iich)%cherod, ch_prms(2)%lo) - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! 1st erodibility adjustment - if (isim > 0) then - write (4601,*) " first erodibility adj " - call time_control - end if - - ! erodibility adjustment for channel downcutting - do ierod = 1, iter_ind - isim = 0 - do ireg = 1, db_mx%cha_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%chd - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%chd) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%erod < 1.e-6) then - isim = 1 - - rmeas = chcal(ireg)%ord(iord)%meas%chd - denom = chcal(ireg)%ord(iord)%prev%chd - chcal(ireg)%ord(iord)%aa%chd - if (abs(denom) > 1.e-6) then - chg_val = (chcal(ireg)%ord(iord)%prm_prev%erod - chcal(ireg)%ord(iord)%prm%erod) & - * (chcal(ireg)%ord(iord)%aa%chd - rmeas) / denom - else - chg_val = chcal(ireg)%ord(iord)%meas%chd / chcal(ireg)%ord(iord)%aa%chd - end if - chcal(ireg)%ord(iord)%prm_prev%erod = chcal(ireg)%ord(iord)%prm%erod - chcal(ireg)%ord(iord)%prm%erod = chcal(ireg)%ord(iord)%prm%erod + chg_val - chcal(ireg)%ord(iord)%prev%chd = chcal(ireg)%ord(iord)%aa%chd - - if (chcal(ireg)%ord(iord)%prm%erod >= ch_prms(2)%pos) then - chg_val = ch_prms(2)%pos - chcal(ireg)%ord(iord)%prm_prev%erod - chcal(ireg)%ord(iord)%prm%erod = ch_prms(2)%pos - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%erod <= ch_prms(2)%neg) then - chg_val = chcal(ireg)%ord(iord)%prm_prev%erod - ch_prms(2)%neg - chcal(ireg)%ord(iord)%prm%erod = ch_prms(2)%neg - chcal(ireg)%ord(iord)%prm_lim%erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !set parms for depth calibration and rerun - sdch_init(iich)%cherod = sdch_init(iich)%cherod / chg_val - sdch_init(iich)%cherod = amin1 (sdch_init(iich)%cherod, ch_prms(2)%up) - sdch_init(iich)%cherod = Max (sdch_init(iich)%cherod, ch_prms(2)%lo) - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! erodibility adjustment - if (isim > 0) then - write (4601,*) " erodibility adj " - call time_control - end if - end do ! ierod - - ! 1st erodibility adjustment for head cut - isim = 0 - do ireg = 1, db_mx%ch_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%hc - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%hc) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%hc_erod < 1.e-6) then - isim = 1 - - chcal(ireg)%ord(iord)%prm_prev = chcal(ireg)%ord(iord)%prm - chcal(ireg)%ord(iord)%prev = chcal(ireg)%ord(iord)%aa - - chg_val = chcal(ireg)%ord(iord)%meas%hc / (chcal(ireg)%ord(iord)%aa%hc + 1.e-6) !assume same ratio of cover and width change - chcal(ireg)%ord(iord)%prm_prev%hc_erod = chcal(ireg)%ord(iord)%prm%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod = chcal(ireg)%ord(iord)%prm%hc_erod + chg_val - chcal(ireg)%ord(iord)%prev%hc = chcal(ireg)%ord(iord)%aa%hc - - if (chcal(ireg)%ord(iord)%prm%hc_erod >= ch_prms(4)%pos) then - chg_val = ch_prms(4)%pos - chcal(ireg)%ord(iord)%prm_prev%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod = ch_prms(4)%pos - chcal(ireg)%ord(iord)%prm_lim%hc_erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%hc_erod <= ch_prms(4)%neg) then - chg_val = ch_prms(4)%neg - chcal(ireg)%ord(iord)%prm_prev%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod = ch_prms(4)%neg - chcal(ireg)%ord(iord)%prm_lim%hc_erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !if height is 0 - no head cut advance - sdch_init(iich)%hc_erod = sdch_init(iich)%hc_erod / chg_val - sdch_init(iich)%hc_erod = amin1 (sdch_init(iich)%hc_erod, ch_prms(4)%up) - sdch_init(iich)%hc_erod = Max (sdch_init(iich)%hc_erod, ch_prms(4)%lo) - !end if - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - !initialize hru and hru_lte - - !! re-initialize all objects - call re_initialize - - ! 1st erodibility adjustment - if (isim > 0) then - write (4601,*) " first head cut erodibility adj " - call time_control - end if - - ! erodibility adjustment for head cut - do ierod = 1, iter_ind - isim = 0 - do ireg = 1, db_mx%cha_reg - do iord = 1, chcal(ireg)%ord_num - soft = chcal(ireg)%ord(iord)%meas%hc - diff = 0. - if (soft > 1.e-6) diff = abs((soft - chcal(ireg)%ord(iord)%aa%hc) / soft) - if (diff > .02 .and. chcal(ireg)%ord(iord)%length > 1.e-6 .and. chcal(ireg)%ord(iord)%prm_lim%hc_erod < 1.e-6) then - isim = 1 - - rmeas = chcal(ireg)%ord(iord)%meas%hc - denom = chcal(ireg)%ord(iord)%prev%hc - chcal(ireg)%ord(iord)%aa%hc - if (abs(denom) > 1.e-6) then - chg_val = - (chcal(ireg)%ord(iord)%prm_prev%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod) & - * (chcal(ireg)%ord(iord)%aa%hc - rmeas) / denom - else - chg_val = chcal(ireg)%ord(iord)%meas%hc / chcal(ireg)%ord(iord)%aa%hc - end if - chcal(ireg)%ord(iord)%prm_prev%hc_erod = chcal(ireg)%ord(iord)%prm%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod = chcal(ireg)%ord(iord)%prm%hc_erod + chg_val - chcal(ireg)%ord(iord)%prev%hc = chcal(ireg)%ord(iord)%aa%hc - - if (chcal(ireg)%ord(iord)%prm%hc_erod >= ch_prms(4)%pos) then - chg_val = ch_prms(4)%pos - chcal(ireg)%ord(iord)%prm_prev%hc_erod - chcal(ireg)%ord(iord)%prm%hc_erod = ch_prms(4)%pos - chcal(ireg)%ord(iord)%prm_lim%hc_erod = 1. - end if - if (chcal(ireg)%ord(iord)%prm%hc_erod <= ch_prms(4)%neg) then - chg_val = chcal(ireg)%ord(iord)%prm_prev%hc_erod - ch_prms(4)%neg - chcal(ireg)%ord(iord)%prm%hc_erod = ch_prms(4)%neg - chcal(ireg)%ord(iord)%prm_lim%hc_erod = 1. - end if - - !check all channels for proper order - do ich_s = 1, chcal(ireg)%num_tot - iich = chcal(ireg)%num(ich_s) - if (chcal(ireg)%ord(iord)%meas%name == sd_ch(iich)%order .or. chcal(ireg)%ord(iord)%meas%name == "basin") then - !if height is 0 - no head cut advance - if (sd_ch(iich)%hc_hgt > 1.e-6) then - sdch_init(iich)%hc_erod = sdch_init(iich)%hc_erod / chg_val - sdch_init(iich)%hc_erod = amin1 (sdch_init(iich)%hc_erod, ch_prms(4)%up) - sdch_init(iich)%hc_erod = Max (sdch_init(iich)%hc_erod, ch_prms(4)%lo) - end if - end if - end do - chcal(ireg)%ord(iord)%nbyr = 0 - chcal(ireg)%ord(iord)%aa = chcal_z - end if - end do - end do - - !! re-initialize all objects - call re_initialize - - ! erodibility adjustment - if (isim > 0) then - write (4601,*) " head cut erodibility adj " - call time_control - end if - end do ! ierod - -777 end do ! iter - - return - end subroutine calsoft_chsed \ No newline at end of file diff --git a/src/calsoft_control.f90 b/src/calsoft_control.f90 index 3a29827..8350920 100644 --- a/src/calsoft_control.f90 +++ b/src/calsoft_control.f90 @@ -98,9 +98,9 @@ subroutine calsoft_control end if !calibrate channel sediment - if (cal_codes%chsed == "y") then - call calsoft_chsed - end if + !if (cal_codes%chsed == "y") then + ! call calsoft_chsed + !end if if (cal_codes%chsed == "y") then do ireg = 1, db_mx%ch_reg @@ -160,7 +160,7 @@ subroutine calsoft_control end do end if ! channel sediment parms - 500 format (a16,f12.3,i12,f12.3,2(1x,a16,10f12.3),10f12.3) +!*** tu Wunused-label: 500 format (a16,f12.3,i12,f12.3,2(1x,a16,10f12.3),10f12.3) 503 format (2a16,f12.5,a) return diff --git a/src/calsoft_hyd_bfr.f90 b/src/calsoft_hyd_bfr.f90 index 03cae4c..cc737c6 100644 --- a/src/calsoft_hyd_bfr.f90 +++ b/src/calsoft_hyd_bfr.f90 @@ -26,8 +26,22 @@ subroutine calsoft_hyd_bfr do iterall = 1, iter_all - ! calibrate harg_pet for potential ET + ! calibrate petco for actual ET + ! start with half the range + ls_prms(4)%neg = ls_prms(4)%neg / 2. + ls_prms(4)%pos = ls_prms(4)%pos / 2. + ls_prms(4)%lo = (1. - ls_prms(4)%lo) / 2. + ls_prms(4)%lo + ls_prms(4)%up = ls_prms(4)%up - (ls_prms(4)%up - 1.) / 2. + call calsoft_hyd_bfr_pet + ! calibrate esco for actual ET call calsoft_hyd_bfr_et + ! calibrate petco for actual ET + ! allow full range + ls_prms(4)%neg = 2. * ls_prms(4)%neg + ls_prms(4)%pos = 2. * ls_prms(4)%pos + ls_prms(4)%lo = ls_prms(4)%lo - (1. - ls_prms(4)%lo) + ls_prms(4)%up = ls_prms(4)%up + (ls_prms(4)%up - 1.) + call calsoft_hyd_bfr_pet ! calibrate cn3_swf for surface runoff call calsoft_hyd_bfr_surq diff --git a/src/calsoft_hyd_bfr_et.f90 b/src/calsoft_hyd_bfr_et.f90 index 945f27a..eeaf17f 100644 --- a/src/calsoft_hyd_bfr_et.f90 +++ b/src/calsoft_hyd_bfr_et.f90 @@ -36,76 +36,15 @@ subroutine calsoft_hyd_bfr_et ! calibrate esco and pet for water yield iter_ind = 1 - ! first calibrate potential et - do ietco = 1, 2 !iter_ind - isim = 0 - do ireg = 1, db_mx%lsu_reg - do ilum = 1, region(ireg)%nlum - soft = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa - pred = lscal(ireg)%lum(ilum)%aa%wyr - diff = 0. - if (soft > 1.e-6) diff = abs((soft - pred) / soft) - if (diff > .01 .and. lscal(ireg)%lum(ilum)%ha > 1.e-6) then - isim = 1 - lscal(ireg)%lum(ilum)%prm_prev = lscal(ireg)%lum(ilum)%prm - lscal(ireg)%lum(ilum)%prev = lscal(ireg)%lum(ilum)%aa - if (soft < pred) then - chg_val = 1. + abs((soft - pred) / soft) - else - chg_val = 1. - abs((pred - soft) / pred) - end if - lscal(ireg)%lum(ilum)%prm_prev%petco = lscal(ireg)%lum(ilum)%prm%petco - if (ietco == 1) then - lscal(ireg)%lum(ilum)%prm%petco = chg_val - else - lscal(ireg)%lum(ilum)%prm%petco = lscal(ireg)%lum(ilum)%prm%petco * chg_val - end if - lscal(ireg)%lum(ilum)%prm_prev%petco = pred - if (lscal(ireg)%lum(ilum)%prm%petco >= ls_prms(4)%pos) then - chg_val = ls_prms(4)%pos - lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%pos - lscal(ireg)%lum(ilum)%prm_lim%petco = 1. - end if - if (lscal(ireg)%lum(ilum)%prm%petco <= ls_prms(4)%neg) then - chg_val = ls_prms(4)%neg - lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%neg - lscal(ireg)%lum(ilum)%prm_lim%petco = 1. - end if - !check all hru"s for proper lum - do ihru_s = 1, region(ireg)%num_tot - iihru = region(ireg)%num(ihru_s) - if (lscal(ireg)%lum(ilum)%meas%name == hru(iihru)%lum_group_c .or. lscal(ireg)%lum(ilum)%meas%name == "basin") then - !set parms for pet adjustment - hru(iihru)%hyd%pet_co = hru(iihru)%hyd%pet_co * chg_val - hru(iihru)%hyd%pet_co = amin1 (hru(iihru)%hyd%pet_co, ls_prms(4)%up) - hru(iihru)%hyd%pet_co = Max (hru(iihru)%hyd%pet_co, ls_prms(4)%lo) - hru_init(iihru)%hyd%pet_co = hru(iihru)%hyd%pet_co - end if - end do - lscal(ireg)%lum(ilum)%nbyr = 0 - lscal(ireg)%lum(ilum)%precip_aa = 0. - lscal(ireg)%lum(ilum)%aa = lscal_z - end if - end do - end do - !! re-initialize all objects - call re_initialize - ! 1st cover adjustment - if (isim > 0) then - cal_sim = " first pet adj " - cal_adj = chg_val - call time_control - end if - end do ! petco iterations ! 1st esco adjustment isim = 0 diff --git a/src/calsoft_hyd_bfr_pet.f90 b/src/calsoft_hyd_bfr_pet.f90 new file mode 100644 index 0000000..8121cad --- /dev/null +++ b/src/calsoft_hyd_bfr_pet.f90 @@ -0,0 +1,96 @@ + subroutine calsoft_hyd_bfr_pet + use hru_module, only : hru, hru_init + use soil_module + use plant_module + use hydrograph_module + use ru_module + use aquifer_module + use channel_module + use hru_lte_module + use sd_channel_module + use basin_module + use maximum_data_module + use calibration_data_module + use conditional_module + use reservoir_module + use organic_mineral_mass_module + use time_module + implicit none + integer :: isim = 0 ! | + integer :: ireg = 0 !none |counter + integer :: ilum = 0 !none |counter + integer :: iihru = 0 !none |counter + integer :: ihru_s = 0 !none |counter + integer :: iter_ind = 0 ! |end of loop + integer :: ietco = 0 !none |counter + real :: rmeas = 0. ! | + real :: denom = 0. ! | + real :: soft = 0. ! | + real :: diff = 0. ! | + real :: chg_val = 0. ! | + real :: pred = 0. + ! calibrate esco and pet for water yield + iter_ind = 1 + ! first calibrate potential et + do ietco = 1, 2 !iter_ind + isim = 0 + do ireg = 1, db_mx%lsu_reg + do ilum = 1, region(ireg)%nlum + soft = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa + pred = lscal(ireg)%lum(ilum)%aa%wyr + diff = 0. + if (soft > 1.e-6) diff = abs((soft - pred) / soft) + if (diff > .01 .and. lscal(ireg)%lum(ilum)%ha > 1.e-6) then + isim = 1 + lscal(ireg)%lum(ilum)%prm_prev = lscal(ireg)%lum(ilum)%prm + lscal(ireg)%lum(ilum)%prev = lscal(ireg)%lum(ilum)%aa + if (soft < pred) then + chg_val = 1. + abs((soft - pred) / soft) + else + chg_val = 1. - abs((pred - soft) / pred) + end if + lscal(ireg)%lum(ilum)%prm_prev%petco = lscal(ireg)%lum(ilum)%prm%petco + if (ietco == 1) then + lscal(ireg)%lum(ilum)%prm%petco = chg_val + else + lscal(ireg)%lum(ilum)%prm%petco = lscal(ireg)%lum(ilum)%prm%petco * chg_val + end if + lscal(ireg)%lum(ilum)%prm_prev%petco = pred + if (lscal(ireg)%lum(ilum)%prm%petco >= ls_prms(4)%pos) then + chg_val = ls_prms(4)%pos + lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%pos + lscal(ireg)%lum(ilum)%prm_lim%petco = 1. + end if + if (lscal(ireg)%lum(ilum)%prm%petco <= ls_prms(4)%neg) then + chg_val = ls_prms(4)%neg + lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%neg + lscal(ireg)%lum(ilum)%prm_lim%petco = 1. + end if + !check all hru"s for proper lum + do ihru_s = 1, region(ireg)%num_tot + iihru = region(ireg)%num(ihru_s) + if (lscal(ireg)%lum(ilum)%meas%name == hru(iihru)%lum_group_c .or. lscal(ireg)%lum(ilum)%meas%name == "basin") then + !set parms for pet adjustment + hru(iihru)%hyd%pet_co = hru(iihru)%hyd%pet_co * chg_val + hru(iihru)%hyd%pet_co = amin1 (hru(iihru)%hyd%pet_co, ls_prms(4)%up) + hru(iihru)%hyd%pet_co = Max (hru(iihru)%hyd%pet_co, ls_prms(4)%lo) + hru_init(iihru)%hyd%pet_co = hru(iihru)%hyd%pet_co + end if + end do + lscal(ireg)%lum(ilum)%nbyr = 0 + lscal(ireg)%lum(ilum)%precip_aa = 0. + lscal(ireg)%lum(ilum)%aa = lscal_z + end if + end do + end do + !! re-initialize all objects + call re_initialize + ! 1st cover adjustment + if (isim > 0) then + cal_sim = " first pet adj " + cal_adj = chg_val + call time_control + end if + end do ! petco iterations + return + end subroutine calsoft_hyd_bfr_pet \ No newline at end of file diff --git a/src/carbon_module.f90 b/src/carbon_module.f90 index cf31b6a..436528e 100644 --- a/src/carbon_module.f90 +++ b/src/carbon_module.f90 @@ -1,27 +1,27 @@ module carbon_module - + implicit none type carbon_terrestrial_inputs real :: er_POC_para = 1.5 ! |POC enrichment ratio ! 0-10 ! 0.0-5.0 MOST SENSITIVE real :: CFB_para = 0.42 ! |Carbon fraction of residue (0.42; from data of Pinck et al., 1950) - real :: Sf_para_sur = 0.05 ! |Fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for below ground litter - real :: Sf_para_sub = 0.10 ! |Fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for belowg round litter + real :: Sf_para_sur = 0.05 ! |Fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for below ground litter + real :: Sf_para_sub = 0.10 ! |Fraction of mineral N sorbed to litter: 0.05 for surface litter, 0.1 for belowg round litter !Dissovled carbon - real :: ABL_para = 0.0 ! |Calculated - Carbon allocation from Microbial Biomass to Leaching + real :: ABL_para = 0.0 ! |Calculated - Carbon allocation from Microbial Biomass to Leaching real :: peroc_DIC_para = 0.95 !0-1 |DIC percolation coefficient - real :: peroc_DOC_para = 0.70 !0-1 |DOC percolation coefficient + real :: peroc_DOC_para = 0.70 !0-1 |DOC percolation coefficient real :: part_DOC_para = 4000. ! |organic carbon partition coefficient 1000 to 1200 ! 500-2000 !replacing KOC=Liquid-solid partition coefficient for Microbial Biomass (10^3 m3 Mg-1) real :: hlife_doc_para = 50. !days |DOC half life in groundwater, calculating DOC decay in groundwater ! 0-100 !Allocation of CO2 and Carbon transformation - real :: ABCO2_para_sur = 0.6 ! |Allocation from Microbial Biomass C pool to CO2; 0.6 (surface Litter), 0.85 - 0.68 x (CLAY+SILT) (all other layers) (Parton et al., 1993, 1994) + real :: ABCO2_para_sur = 0.6 ! |Allocation from Microbial Biomass C pool to CO2; 0.6 (surface Litter), 0.85 - 0.68 x (CLAY+SILT) (all other layers) (Parton et al., 1993, 1994) real :: ABCO2_para_sub = 0. ! |Calculated -Allocation from Microbial Biomass C pool to CO2; 0.6 (surface Litter), 0.85 - 0.68 x (CLAY+SILT) (all other layers) (Parton et al., 1993, 1994) - real :: ABP_para_sur = 0.0 ! |Allocation from Biomass to passive Humus; 0 (surface Litter), 0.003 + 0.032 x SOL_CLAY (all other layers) (Parton et al., 1993, 1994) + real :: ABP_para_sur = 0.0 ! |Allocation from Biomass to passive Humus; 0 (surface Litter), 0.003 + 0.032 x SOL_CLAY (all other layers) (Parton et al., 1993, 1994) real :: ABP_para_sub = 0.0 ! |Calculated - Allocation from Biomass to passive Humus; 0 (surface Litter), 0.003 + 0.032 x SOL_CLAY (all other layers) (Parton et al., 1993, 1994) - real :: ALMCO2_para_sur = 0.6 ! |Allocation from metabolic Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) - real :: ALMCO2_para_sub = 0.55 ! |Allocation from metabolic Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) + real :: ALMCO2_para_sur = 0.6 ! |Allocation from metabolic Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) + real :: ALMCO2_para_sub = 0.55 ! |Allocation from metabolic Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) real :: ALSLNCO2_para_sur = 0.6 ! |Allocation from non-lignin of structural Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) - real :: ALSLNCO2_para_sub =0.55 ! |Allocation from non-lignin of structural Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) + real :: ALSLNCO2_para_sub =0.55 ! |Allocation from non-lignin of structural Litter to CO2; 0.6 (surface Litter), 0.55 (all other layers) (Parton et al., 1993, 1994) real :: ASP_para_sur = 0.0 ! |Allocation from slow Humus to passive; 0 (surface Litter), 0.003 + 0.00009 x CLAF (all other layers) (Parton et al., 1993, 1994) real :: ASP_para_sub = 0.0 ! |Calculated - Allocation from slow Humus to passive; 0 (surface Litter), 0.003 + 0.00009 x CLAF (all other layers) (Parton et al., 1993, 1994) real :: ALSLCO2_para = 0.3 ! |Allocation from lignin of structural Litter to CO2; 0.3 (Parton et al., 1993, 1994) @@ -30,8 +30,8 @@ module carbon_module !decomposition rates real :: PRMT_51_para = 1.0 ! |COEF ADJUSTS MICROBIAL ACTIVITY FUNCTION IN TOP SOIL LAYER (0.1_1.), real :: PRMT_45_para = 0.003 ! |COEF IN CENTURY EQ ALLOCATING SLOW TO PASSIVE HUMUS(0.001_0.05) ORIGINAL VALUE = 0.003, ASP=MAX(.001,PRMT_45-.00009*sol_clay(k,j)), ASP=MAX(.001,PRMT_45+.009*sol_clay(k,j)/100) - real :: BMR_para_sur = 0.0164 ! |Rate of transformation of microbial Biomass and associated products under optimal conditions (surface = 0.0164 d-1; all other layers = 0.02 d-1) (Parton et al., 1993, 1994) - real :: BMR_para_sub = 0.02 ! |Rate of transformation of microbial Biomass and associated products under optimal conditions (surface = 0.0164 d-1; all other layers = 0.02 d-1) (Parton et al., 1993, 1994) + real :: BMR_para_sur = 0.0164 ! |Rate of transformation of microbial Biomass and associated products under optimal conditions (surface = 0.0164 d-1; all other layers = 0.02 d-1) (Parton et al., 1993, 1994) + real :: BMR_para_sub = 0.02 ! |Rate of transformation of microbial Biomass and associated products under optimal conditions (surface = 0.0164 d-1; all other layers = 0.02 d-1) (Parton et al., 1993, 1994) real :: HPR_para = 0.000012 ! |Rate of transformation of passive Humus under optimal conditions (subsurface layers = 0.000012 d-1) (Parton et al., 1993, 1994) real :: HSR_para = 0.000548 ! |Rate of transformation of slow Humus under optimal conditions (all layers = 0.0005 d-1) (Parton et al., 1993, 1994; Vitousek et al., 1993) real :: LMR_para_sur = 0.0405 ! |Rate of transformation of metabolic Litter under optimal conditions (surface = 0.0405 d-1; all other layers = 0.0507 d-1) (Parton et al., 1994) @@ -62,32 +62,32 @@ module carbon_module end type carbon_inputs type (carbon_inputs) :: carbdb type (carbon_inputs) :: carbz - + type organic_allocations real :: abco2 = 0. ! |Fraction of decomposed microbial biomass allocated to CO2 - real :: abl = 0. ! |Fraction of microbial biomass loss due to leaching - real :: abp = 0. ! |Fraction of decomposed microbial biomass allocated to passive humus - real :: almco2 = 0. ! |Fraction of decomposed metabolic litter allocated to CO2 - real :: alslco2 = 0. ! |Fraction of decomposed lignin of structural litter allocated to CO2 - real :: alslnco2 = 0. ! |Fraction of decomposed lignin of structural litter allocated to CO2 - real :: apco2 = 0. ! |Fraction of decomposed passive humus allocated to CO2 - real :: asco2 = 0. ! |Fraction of decomposed slow humus allocated to CO2 - real :: asp = 0. ! |Fraction of decomposed slow humus allocated to passive + real :: abl = 0. ! |Fraction of microbial biomass loss due to leaching + real :: abp = 0. ! |Fraction of decomposed microbial biomass allocated to passive humus + real :: almco2 = 0. ! |Fraction of decomposed metabolic litter allocated to CO2 + real :: alslco2 = 0. ! |Fraction of decomposed lignin of structural litter allocated to CO2 + real :: alslnco2 = 0. ! |Fraction of decomposed lignin of structural litter allocated to CO2 + real :: apco2 = 0. ! |Fraction of decomposed passive humus allocated to CO2 + real :: asco2 = 0. ! |Fraction of decomposed slow humus allocated to CO2 + real :: asp = 0. ! |Fraction of decomposed slow humus allocated to passive end type organic_allocations type (organic_allocations) :: org_allo type (organic_allocations) :: org_alloz - + type organic_controls - real :: cdg = 0. ! |soil temperature control on biological processes - real :: cs = 0. ! |combined factor controlling biological processes - real :: ox = 0. ! |oxygen control on biological processes - real :: sut = 0. ! |soil water control on biological processes - real :: x1 = 0. ! |tillage control on residue decomposition + real :: cdg = 0. ! |soil temperature control on biological processes + real :: cs = 0. ! |combined factor controlling biological processes + real :: ox = 0. ! |oxygen control on biological processes + real :: sut = 0. ! |soil water control on biological processes + real :: x1 = 0. ! |tillage control on residue decomposition real :: xbmt = 0. ! |control on transformation of microbial biomass by soil texture and structure real :: xlslf = 0. ! |control on potential transformation of structural litter by lignin fraction end type organic_controls type (organic_controls) :: org_con - + type organic_fractions real :: lmf = 0. !frac |fraction of the litter that is metabolic real :: lmnf = 0. !kg kg-1 |fraction of metabolic litter that is N @@ -101,23 +101,23 @@ module carbon_module real :: cnr = 0. ! |c/n ratio of standing dead real :: ncbm = 0. ! |n/c ratio of biomass real :: nchp = 0. ! |n/c ratio of passive humus - real :: nchs = 0. ! |n/c ration of slow humus + real :: nchs = 0. ! |n/c ration of slow humus end type organic_ratio type (organic_ratio) :: org_ratio - + type organic_transformations real :: bmctp = 0. !kg ha-1 day-1 |potential transformation of C in microbial biomass - real :: bmntp = 0. !kg ha-1 day-1 |potential transformation of N in microbial biomass - real :: hsctp = 0. !kg ha-1 day-1 |potential transformation of C in slow humus - real :: hsntp = 0. !kg ha-1 day-1 |potential transformation of N in slow humus + real :: bmntp = 0. !kg ha-1 day-1 |potential transformation of N in microbial biomass + real :: hsctp = 0. !kg ha-1 day-1 |potential transformation of C in slow humus + real :: hsntp = 0. !kg ha-1 day-1 |potential transformation of N in slow humus real :: hpctp = 0. !kg ha-1 day-1 |potential transformation of C in passive humus real :: hpntp = 0. !kg ha-1 day-1 |potential transformation of N in passive humus real :: lmctp = 0. !kg ha-1 day-1 |potential transformation of C in metabolic litter - real :: lmntp = 0. !kg ha-1 day-1 |potential transformation of N in metabolic litter + real :: lmntp = 0. !kg ha-1 day-1 |potential transformation of N in metabolic litter real :: lsctp = 0. !kg ha-1 day-1 |potential transformation of C in structural litter real :: lslctp = 0. !kg ha-1 day-1 |potential transformation of C in lignin of structural litter real :: lslnctp = 0. !kg ha-1 day-1 |potential transformation of C in nonlignin structural litter - real :: lsntp = 0. !kg ha-1 day-1 |potential transformation of N in structural litter + real :: lsntp = 0. !kg ha-1 day-1 |potential transformation of N in structural litter end type organic_transformations type (organic_transformations) :: org_tran @@ -231,7 +231,7 @@ module carbon_module type (carbon_soil_gain_losses) :: bsc_a type carbon_residue_gain_losses - real :: plant_c = 0. !kg C/ha |carbon added to residue from leaf drop and kill + real :: plant_c = 0. !kg C/ha |carbon added to residue from leaf drop and kill real :: res_decay_c = 0. !kg C/ha |carbon lost to soil from residue decay real :: harv_stov_c = 0. !kg C/ha |carbon removed during residue harvest real :: emit_c = 0. !kg C/ha |CO2 production from burning residue carbon diff --git a/src/cbn_zhang2.f90 b/src/cbn_zhang2.f90 index 1317247..64de2c4 100644 --- a/src/cbn_zhang2.f90 +++ b/src/cbn_zhang2.f90 @@ -279,12 +279,20 @@ subroutine cbn_zhang2 j = ihru + !! calculate carbon loss in surface residue + !soil1(j)%str(k)%n = soil1(j)%str(k)%n * (1. - decr) + !soil1(j)%lig(k)%n = soil1(j)%lig(k)%n * (1. - decr) + !soil1(j)%meta(k)%n = soil1(j)%meta(k)%n * (1. - decr) + !soil1(j)%str(k)%p = soil1(j)%str(k)%p * (1. - decr) + !soil1(j)%lig(k)%p = soil1(j)%lig(k)%p * (1. - decr) + !soil1(j)%meta(k)%p = soil1(j)%meta(k)%p * (1. - decr) + !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 + end if !!calculate c/n dynamics for each soil layer !!=========================================== @@ -333,11 +341,11 @@ subroutine cbn_zhang2 till_eff = 1.6 else if (soil(j)%phys(k-1)%d .lt. tillage_depth(j)) then till_eff = 1.0 + 0.6 * (tillage_depth(j) - soil(j)%phys(k-1)%d) / (soil(j)%phys(k)%d - soil(j)%phys(k-1)%d) - end if + end if end if else till_eff = 1.0 - end if + end if !!compute soil temperature factor - when sol_tep is larger than 35, cdg is negative? org_con%cdg = soil(j)%phys(k)%tmp / (soil(j)%phys(k)%tmp + exp(5.058459 - 0.2503591 * soil(j)%phys(k)%tmp)) @@ -630,16 +638,16 @@ subroutine cbn_zhang2 ! update if (rnmn > 0.) then soil1(j)%mn(k)%nh4 = soil1(j)%mn(k)%nh4 + rnmn - min_n = soil1(j)%mn(k)%no3 + rnmn - if (min_n < 0.) then - rnmn = -soil1(j)%mn(k)%no3 - soil1(j)%mn(k)%no3 = 1.e-10 - else - soil1(j)%mn(k)%no3 = min_n + min_n = soil1(j)%mn(k)%no3 + rnmn + if (min_n < 0.) then + rnmn = -soil1(j)%mn(k)%no3 + soil1(j)%mn(k)%no3 = 1.e-10 + else + soil1(j)%mn(k)%no3 = min_n end if end if - ! calculate p flows + ! calculate p flows ! compute humus mineralization on active organic p hmp_rate = 1.4 * (hsnta + hpnta) / (soil1(j)%hs(k)%n + soil1(j)%hp(k)%n + 1.e-6) @@ -647,9 +655,9 @@ subroutine cbn_zhang2 hmp = hmp_rate * soil1(j)%hp(k)%p hmp = min(hmp, soil1(j)%hp(k)%p) soil1(j)%hp(k)%p = soil1(j)%hp(k)%p - hmp - soil1(j)%mp(k)%lab = soil1(j)%mp(k)%lab + hmp - - !! compute residue decomp and mineralization of + soil1(j)%mp(k)%lab = soil1(j)%mp(k)%lab + hmp + + !! compute residue decomp and mineralization of !! fresh organic n and p (upper two layers only) decr = (lscta + lmcta) / (soil1(j)%str(k)%c + soil1(j)%meta(k)%c + 1.e-6) decr = min(1., decr) @@ -657,12 +665,12 @@ subroutine cbn_zhang2 soil1(j)%tot(k)%p = soil1(j)%tot(k)%p - rmp soil1(j)%mp(k)%lab = soil1(j)%mp(k)%lab + .8 * rmp - soil1(j)%hp(k)%p = soil1(j)%hp(k)%p + .2 * rmp + soil1(j)%hp(k)%p = soil1(j)%hp(k)%p + .2 * rmp !!!================================= !!determine the final rate of the decomposition of each carbon pool and !!allocation of c and nutrients to different som pools, as well as co2 emissions from different pools - lscta = min(soil1(j)%str(k)%c, lscta) + lscta = min(soil1(j)%str(k)%c, lscta) lslcta = min(soil1(j)%lig(k)%c, lslcta) org_flux%co2fstr = .3 * lslcta @@ -775,7 +783,7 @@ subroutine cbn_zhang2 !!epic procedures (not used): calculating n supply - n demand !!df1 is the supply of n during structural litter decomposition (lsnta) - demand of n to meet the transformaitons of other pools !! c pools into structural litter (0 as no other pools transformed into structural litter) - df1 = lsnta + df1 = lsnta !!df2 is the supply of n during metabolic litter decomposition (lsnta) - demand of n to meet the transformaitons of other pools !! c pools into metabolic litter (0 as no other pools transformed into structural litter) diff --git a/src/ch_initial.f90 b/src/ch_initial.f90 index f350e01..fd0edf3 100644 --- a/src/ch_initial.f90 +++ b/src/ch_initial.f90 @@ -16,84 +16,84 @@ subroutine ch_initial (idat, irch) bnksize = ch_sed(ised)%bnk_d50 / 1000. !! Units conversion Micrometer to Millimeters !! Channel sediment particle size distribution !! Clayey bank - if (bnksize <= 0.005) then - ch(irch)%bnk_cla = 0.65 + if (bnksize <= 0.005) then + ch(irch)%bnk_cla = 0.65 ch(irch)%bnk_sil = 0.15 - ch(irch)%bnk_san = 0.15 - ch(irch)%bnk_gra = 0.05 - end if + ch(irch)%bnk_san = 0.15 + ch(irch)%bnk_gra = 0.05 + end if !! Silty bank - if (bnksize > 0.005 .and. bnksize <= 0.05) then + if (bnksize > 0.005 .and. bnksize <= 0.05) then ch(irch)%bnk_sil = 0.65 - ch(irch)%bnk_cla = 0.15 - ch(irch)%bnk_san = 0.15 - ch(irch)%bnk_gra = 0.05 - end if + ch(irch)%bnk_cla = 0.15 + ch(irch)%bnk_san = 0.15 + ch(irch)%bnk_gra = 0.05 + end if !! Sandy bank - if (bnksize > 0.05 .and. bnksize <= 2.) then - ch(irch)%bnk_san = 0.65 + if (bnksize > 0.05 .and. bnksize <= 2.) then + ch(irch)%bnk_san = 0.65 ch(irch)%bnk_sil = 0.15 - ch(irch)%bnk_cla = 0.15 - ch(irch)%bnk_gra = 0.05 - end if + ch(irch)%bnk_cla = 0.15 + ch(irch)%bnk_gra = 0.05 + end if !! Gravel bank - if (bnksize > 2.) then - ch(irch)%bnk_gra = 0.65 - ch(irch)%bnk_san = 0.15 + if (bnksize > 2.) then + ch(irch)%bnk_gra = 0.65 + ch(irch)%bnk_san = 0.15 ch(irch)%bnk_sil = 0.15 - ch(irch)%bnk_cla = 0.05 - end if + ch(irch)%bnk_cla = 0.05 + end if !! Channel sediment particle size distribution !! Clayey bed bedsize = ch_sed(ised)%bed_d50 / 1000. !! Units conversion Micrometer to Millimeters - if (bedsize <= 0.005) then - ch(irch)%bed_cla = 0.65 + if (bedsize <= 0.005) then + ch(irch)%bed_cla = 0.65 ch(irch)%bed_sil = 0.15 - ch(irch)%bed_san = 0.15 - ch(irch)%bed_gra = 0.05 - end if + ch(irch)%bed_san = 0.15 + ch(irch)%bed_gra = 0.05 + end if !! Silty bed - if (bedsize > 0.005 .and. bedsize <= 0.05) then + if (bedsize > 0.005 .and. bedsize <= 0.05) then ch(irch)%bed_sil = 0.65 - ch(irch)%bed_cla = 0.15 - ch(irch)%bed_san = 0.15 - ch(irch)%bed_gra = 0.05 - end if + ch(irch)%bed_cla = 0.15 + ch(irch)%bed_san = 0.15 + ch(irch)%bed_gra = 0.05 + end if !! Sandy bed - if (bedsize > 0.05 .and. bedsize <= 2.) then - ch(irch)%bed_san = 0.65 + if (bedsize > 0.05 .and. bedsize <= 2.) then + ch(irch)%bed_san = 0.65 ch(irch)%bed_sil = 0.15 - ch(irch)%bed_cla = 0.15 - ch(irch)%bed_gra = 0.05 - end if + ch(irch)%bed_cla = 0.15 + ch(irch)%bed_gra = 0.05 + end if !! Gravel bed - if (bedsize > 2.) then - ch(irch)%bed_gra = 0.65 - ch(irch)%bed_san = 0.15 + if (bedsize > 2.) then + ch(irch)%bed_gra = 0.65 + ch(irch)%bed_san = 0.15 ch(irch)%bed_sil = 0.15 - ch(irch)%bed_cla = 0.05 + ch(irch)%bed_cla = 0.05 end if !! An estimate of Critical shear stress if it is not given (N/m^2) -!! Critical shear stress based on silt and clay % -!! Critical Shear Stress based on Julian and Torres (2005) +!! Critical shear stress based on silt and clay % +!! Critical Shear Stress based on Julian and Torres (2005) !! Units of critical shear stress (N/m^2) - SC = 0. - if (ch_sed(ised)%tc_bnk <= 1.e-6) then - SC = (ch(irch)%bnk_sil + ch(irch)%bnk_cla) * 100. + SC = 0. + if (ch_sed(ised)%tc_bnk <= 1.e-6) then + SC = (ch(irch)%bnk_sil + ch(irch)%bnk_cla) * 100. ch_sed(ised)%tc_bnk = (0.1 + (0.1779*SC) + (0.0028*(SC)**2) & - ((2.34E-05)*(SC)**3)) * ch_sed(ised)%cov1 end if - if (ch_sed(ised)%tc_bed <= 1.e-6) then - SC = (ch(irch)%bed_sil + ch(irch)%bed_cla) * 100. + if (ch_sed(ised)%tc_bed <= 1.e-6) then + SC = (ch(irch)%bed_sil + ch(irch)%bed_cla) * 100. ch_sed(ised)%tc_bed = (0.1 + (0.1779*SC) + (0.0028*(SC)**2) & - ((2.34E-05)*(SC)**3)) * ch_sed(ised)%cov2 end if diff --git a/src/ch_pathogen_output.f90 b/src/ch_pathogen_output.f90 index e434f29..89706ba 100644 --- a/src/ch_pathogen_output.f90 +++ b/src/ch_pathogen_output.f90 @@ -98,9 +98,9 @@ subroutine ch_pathogen_output(ihru) return 100 format (4i6,2i8,2x,a,28f12.3) -101 format (4i6,2i8,2x,a,20f12.3) -102 format (4i6,2i8,2x,a,20f12.3) -103 format (2i6,i8,4x,a,5x,f12.3) -104 format (4i6,2i8,2x,a,27f18.3) +!*** tu Wunused-label: 101 format (4i6,2i8,2x,a,20f12.3) +!*** tu Wunused-label: 102 format (4i6,2i8,2x,a,20f12.3) +!*** tu Wunused-label: 103 format (2i6,i8,4x,a,5x,f12.3) +!*** tu Wunused-label: 104 format (4i6,2i8,2x,a,27f18.3) end subroutine ch_pathogen_output \ No newline at end of file diff --git a/src/ch_read_elements.f90 b/src/ch_read_elements.f90 index d0a6ba7..f2a6af7 100644 --- a/src/ch_read_elements.f90 +++ b/src/ch_read_elements.f90 @@ -74,7 +74,7 @@ subroutine ch_read_elements db_mx%cha_reg = mreg end do - end if + end if !! setting up regions for channel soft cal and/or output by order inquire (file=in_regs%def_cha_reg, exist=i_exist) @@ -118,7 +118,7 @@ subroutine ch_read_elements db_mx%cha_reg = mreg end do - end if + end if !! if no regions are input, don"t need elements if (mreg > 0) then diff --git a/src/ch_read_sed.f90 b/src/ch_read_sed.f90 index 6b66358..b57b597 100644 --- a/src/ch_read_sed.f90 +++ b/src/ch_read_sed.f90 @@ -66,13 +66,13 @@ subroutine ch_read_sed if (ch_sed(ich)%cov2 <= 0.0) ch_sed(ich)%cov2 = 0.0 if (ch_sed(ich)%cov1 >= 1.0) ch_sed(ich)%cov1 = 1.0 if (ch_sed(ich)%cov2 >= 1.0) ch_sed(ich)%cov2 = 1.0 - else + else if (ch_sed(ich)%cov1 <= 0.0) ch_sed(ich)%cov1 = 1.0 if (ch_sed(ich)%cov2 <= 0.0) ch_sed(ich)%cov2 = 1.0 if (ch_sed(ich)%cov1 >= 25.) ch_sed(ich)%cov1 = 25. if (ch_sed(ich)%cov2 >= 25.) ch_sed(ich)%cov2 = 25. - end if - + end if + !! Bank material is assumed to be silt type partcile if not given. if (ch_sed(ich)%bnk_d50 <= 1.e-6) ch_sed(ich)%bnk_d50 = 50. !! Units are in Micrometer @@ -83,31 +83,31 @@ subroutine ch_read_sed if (ch_sed(ich)%bed_d50 > 10000) ch_sed(ich)%bed_d50 = 10000. !! Bulk density of channel bank sediment - if (ch_sed(ich)%bnk_bd <= 1.e-6) ch_sed(ich)%bnk_bd = 1.40 !! Silty loam bank + if (ch_sed(ich)%bnk_bd <= 1.e-6) ch_sed(ich)%bnk_bd = 1.40 !! Silty loam bank !! Bulk density of channel bed sediment - if (ch_sed(ich)%bed_bd <= 1.e-6) ch_sed(ich)%bed_bd = 1.50 !! Sandy loam bed + if (ch_sed(ich)%bed_bd <= 1.e-6) ch_sed(ich)%bed_bd = 1.50 !! Sandy loam bed !! An estimate of channel bank erodibility coefficient from jet test if it is not available !! Units of kd is (cm^3/N/s) !! Base on Hanson and Simon, 2001 if (ch_sed(ich)%bnk_kd <= 1.e-6) then - if (ch_sed(ich)%tc_bnk <= 1.e-6) then - ch_sed(ich)%bnk_kd = 0.2 - else + if (ch_sed(ich)%tc_bnk <= 1.e-6) then + ch_sed(ich)%bnk_kd = 0.2 + else ch_sed(ich)%bnk_kd = 0.2 / sqrt(ch_sed(ich)%tc_bnk) - end if - end if + end if + end if !! An estimate of channel bed erodibility coefficient from jet test if it is not available !! Units of kd is (cm^3/N/s) !! Base on Hanson and Simon, 2001 if (ch_sed(ich)%bed_kd <= 1.e-6) then - if (ch_sed(ich)%tc_bed <= 1.e-6) then - ch_sed(ich)%bed_kd = 0.2 - else + if (ch_sed(ich)%tc_bed <= 1.e-6) then + ch_sed(ich)%bed_kd = 0.2 + else ch_sed(ich)%bed_kd = 0.2 / sqrt(ch_sed(ich)%tc_bed) - end if + end if end if sumerod = 0. diff --git a/src/ch_rtday.f90 b/src/ch_rtday.f90 index 7eac0d3..050a6c1 100644 --- a/src/ch_rtday.f90 +++ b/src/ch_rtday.f90 @@ -101,15 +101,15 @@ subroutine ch_rtday !! Find maximum flow capacity of the channel at bank full c = ch_hyd(jhyd)%side - p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c) - rh = ch_vel(jrch)%area / p - maxrt = Qman(ch_vel(jrch)%area, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s) + p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c) + rh = ch_vel(jrch)%area / p + maxrt = Qman(ch_vel(jrch)%area, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s) sdti = 0. - rchdep = 0. - p = 0. - rh = 0. - vc = 0. + rchdep = 0. + p = 0. + rh = 0. + vc = 0. ch(jrch)%chfloodvol = 0. !! If average flowrate is greater than than the channel capacity at bank full @@ -139,44 +139,44 @@ subroutine ch_rtday end if if (volrt > maxrt) then - rcharea = ch_vel(jrch)%area - rchdep = ch_hyd(jhyd)%d - p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c) - rh = ch_vel(jrch)%area / p - sdti = maxrt - adddep = 0 - !! find the crossectional area and depth for volrt - !! by iteration method at 1cm interval depth - !! find the depth until the discharge rate is equal to volrt + rcharea = ch_vel(jrch)%area + rchdep = ch_hyd(jhyd)%d + p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c) + rh = ch_vel(jrch)%area / p + sdti = maxrt + adddep = 0 + !! find the crossectional area and depth for volrt + !! by iteration method at 1cm interval depth + !! find the depth until the discharge rate is equal to volrt itermx = 0 - Do While (sdti < volrt) + Do While (sdti < volrt) adddep = adddep + 0.01 addarea = rcharea + ((ch_hyd(jhyd)%w * 5) + 4 * adddep) * adddep addp = p + (ch_hyd(jhyd)%w * 4) + 2. * adddep * Sqrt(1. + 4 * 4) - rh = addarea / addp + rh = addarea / addp sdti = Qman(addarea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s) itermx = itermx + 1 if (itermx > 100) exit - end do - rcharea = addarea - rchdep = ch_hyd(jhyd)%d + adddep - p = addp - sdti = volrt + end do + rcharea = addarea + rchdep = ch_hyd(jhyd)%d + adddep + p = addp + sdti = volrt ! store floodplain water that can be used by riparian HRU"s - else - !! find the crossectional area and depth for volrt - !! by iteration method at 1cm interval depth - !! find the depth until the discharge rate is equal to volrt - Do While (sdti < volrt) - rchdep = rchdep + 0.01 - rcharea = (ch_vel(jrch)%wid_btm + c * rchdep) * rchdep - p = ch_vel(jrch)%wid_btm + 2. * rchdep * Sqrt(1. + c * c) - rh = rcharea / p + else + !! find the crossectional area and depth for volrt + !! by iteration method at 1cm interval depth + !! find the depth until the discharge rate is equal to volrt + Do While (sdti < volrt) + rchdep = rchdep + 0.01 + rcharea = (ch_vel(jrch)%wid_btm + c * rchdep) * rchdep + p = ch_vel(jrch)%wid_btm + 2. * rchdep * Sqrt(1. + c * c) + rh = rcharea / p sdti = Qman(rcharea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s) - end do - sdti = volrt - end if + end do + sdti = volrt + end if !! calculate top width of channel at water level topw = 0. @@ -193,9 +193,9 @@ subroutine ch_rtday if (sdti > 0.) then !! calculate velocity and travel time - vc = sdti / rcharea + vc = sdti / rcharea ch(jrch)%vel_chan = vc - rttime = ch_hyd(jhyd)%l * 1000. / (3600. * vc) + rttime = ch_hyd(jhyd)%l * 1000. / (3600. * vc) !! calculate volume of water leaving reach on day scoef = 2. * det / (2. * rttime + det) @@ -217,77 +217,77 @@ subroutine ch_rtday !! channel storage and from volume flowing out !! calculate transmission losses - rttlc = 0. + rttlc = 0. - if (rtwtr > 0.) then + if (rtwtr > 0.) then - !! Total time in hours to clear the water + !! Total time in hours to clear the water rttlc = det * ch_hyd(jhyd)%k * ch_hyd(jhyd)%l * p - if (ch(jrch)%rchstor <= rttlc) then - rttlc1 = min(rttlc, ch(jrch)%rchstor) - ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc1 - rttlc2 = rttlc - rttlc1 - if (rtwtr <= rttlc2) then - rttlc2 = min(rttlc2, rtwtr) - rtwtr = rtwtr - rttlc2 - else - rtwtr = rtwtr - rttlc2 + if (ch(jrch)%rchstor <= rttlc) then + rttlc1 = min(rttlc, ch(jrch)%rchstor) + ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc1 + rttlc2 = rttlc - rttlc1 + if (rtwtr <= rttlc2) then + rttlc2 = min(rttlc2, rtwtr) + rtwtr = rtwtr - rttlc2 + else + rtwtr = rtwtr - rttlc2 end if rttlc = rttlc1 + rttlc2 - else - ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc - end if + else + ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc + end if end if !! calculate evaporation - rtevp = 0. + rtevp = 0. if (rtwtr > 0.) then aaa = bsn_prm%evrch * pet_ch / 1000. * rt_delt - if (rchdep <= ch_hyd(jhyd)%d) then + if (rchdep <= ch_hyd(jhyd)%d) then rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw - else - if (aaa <= (rchdep - ch_hyd(jhyd)%d)) then + else + if (aaa <= (rchdep - ch_hyd(jhyd)%d)) then rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw - else - rtevp = (rchdep - ch_hyd(jhyd)%d) - rtevp = rtevp + (aaa - (rchdep - ch_hyd(jhyd)%d)) + else + rtevp = (rchdep - ch_hyd(jhyd)%d) + rtevp = rtevp + (aaa - (rchdep - ch_hyd(jhyd)%d)) topw = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * c - rtevp = rtevp * ch_hyd(jhyd)%l * 1000. * topw - end if - end if + rtevp = rtevp * ch_hyd(jhyd)%l * 1000. * topw + end if + end if - rtevp2 = rtevp * ch(jrch)%rchstor / (rtwtr + ch(jrch)%rchstor) + rtevp2 = rtevp * ch(jrch)%rchstor / (rtwtr + ch(jrch)%rchstor) - if (ch(jrch)%rchstor <= rtevp2) then - rtevp2 = min(rtevp2, ch(jrch)%rchstor) - ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2 - rtevp1 = rtevp - rtevp2 - if (rtwtr <= rtevp1) then - rtevp1 = min(rtevp1, rtwtr) - rtwtr = rtwtr - rtevp1 - else - rtwtr = rtwtr - rtevp1 - end if - else - ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2 - rtevp1 = rtevp - rtevp2 - if (rtwtr <= rtevp1) then - rtevp1 = min(rtevp1, rtwtr) - rtwtr = rtwtr - rtevp1 - else - rtwtr = rtwtr - rtevp1 - end if - end if - rtevp = rtevp1 + rtevp2 + if (ch(jrch)%rchstor <= rtevp2) then + rtevp2 = min(rtevp2, ch(jrch)%rchstor) + ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2 + rtevp1 = rtevp - rtevp2 + if (rtwtr <= rtevp1) then + rtevp1 = min(rtevp1, rtwtr) + rtwtr = rtwtr - rtevp1 + else + rtwtr = rtwtr - rtevp1 + end if + else + ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2 + rtevp1 = rtevp - rtevp2 + if (rtwtr <= rtevp1) then + rtevp1 = min(rtevp1, rtwtr) + rtwtr = rtwtr - rtevp1 + else + rtwtr = rtwtr - rtevp1 + end if + end if + rtevp = rtevp1 + rtevp2 end if else rtwtr = 0. sdti = 0. - ch(jrch)%rchstor = 0. - ch(jrch)%vel_chan = 0. + ch(jrch)%rchstor = 0. + ch(jrch)%vel_chan = 0. ch(jrch)%flwin = 0. ch(jrch)%flwout = 0. end if diff --git a/src/ch_rthr.f90 b/src/ch_rthr.f90 index 5c2f5b1..6ede8b5 100644 --- a/src/ch_rthr.f90 +++ b/src/ch_rthr.f90 @@ -3,7 +3,7 @@ subroutine ch_rthr !! ~ ~ ~ PURPOSE ~ ~ ~ !! This subroutine routes flow at any required time step through the reach !! using a constant storage coefficient -!! Routing method: Variable Storage routing +!! Routing method: Variable Storage routing !! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ !! name |units |definition @@ -34,7 +34,7 @@ subroutine ch_rthr !! subroutine developed by A. Van Griensven, !! Hydrology-Vrije Universiteit Brussel, Belgium -!! Modified by Jeahak Jeong, Blackland Research, Temple, USA +!! Modified by Jeahak Jeong, Blackland Research, Temple, USA use basin_module use climate_module diff --git a/src/ch_rtmusk.f90 b/src/ch_rtmusk.f90 index c2b2a0e..6ebac06 100644 --- a/src/ch_rtmusk.f90 +++ b/src/ch_rtmusk.f90 @@ -151,7 +151,7 @@ subroutine ch_rtmusk !! Muskingum flood routing method outflo = sd_ch(jrch)%msk%c1 * inflo + sd_ch(jrch)%msk%c2 * sd_ch(jrch)%in1_vol + & sd_ch(jrch)%msk%c3 * sd_ch(jrch)%out1_vol - outflo = Min (outflo, tot_stor(jrch)%flo) + outflo = Min (outflo, tot_stor(jrch)%flo) outflo = Max (outflo, 0.) !! save inflow/outflow volumes for next time step (and day) for Muskingum @@ -161,6 +161,7 @@ subroutine ch_rtmusk !! Variable Storage Coefficent method - sc=2*dt/(2*ttime+dt) - ttime=(in2+out1)/2 scoef = dthr / (ch_rcurv(jrch)%in2%ttime + ch_rcurv(jrch)%out1%ttime + dthr) + scoef = bsn_prm%scoef * 2. * dthr / (2.* ch_rcurv(jrch)%out1%ttime + dthr) !***jga scoef = Min (scoef, 1.) outflo = scoef * tot_stor(jrch)%flo end if diff --git a/src/ch_rtpath.f90 b/src/ch_rtpath.f90 index b6b815d..c458a69 100644 --- a/src/ch_rtpath.f90 +++ b/src/ch_rtpath.f90 @@ -89,9 +89,9 @@ subroutine ch_rtpath !! new concentration netwtr = ob(icmd)%hin%flo + rchwtr - - !! change made by CS while running region 4; date 2 jan 2006 - if (path_tot < 1.e-6) path_tot = 0.0 + + !! change made by CS while running region 4; date 2 jan 2006 + if (path_tot < 1.e-6) path_tot = 0.0 if (netwtr >= 1.) then ch_water(jrch)%path(ipath) = path_tot / netwtr else diff --git a/src/ch_rtpest.f90 b/src/ch_rtpest.f90 index f039a51..c017659 100644 --- a/src/ch_rtpest.f90 +++ b/src/ch_rtpest.f90 @@ -160,7 +160,7 @@ subroutine ch_rtpest !! calculate amount of pesticide that undergoes chemical or biological degradation on day in reach pest_init = chpstmass if (pest_init > 1.e-12) then - pest_end = chpstmass * (pestcp(jpst)%decay_a * tday) + pest_end = chpstmass * (pestcp(jpst)%decay_a ** tday) chpstmass = pest_end chpst%pest(ipest)%react = pest_init - pest_end !! add decay to daughter pesticides diff --git a/src/ch_watqual4.f90 b/src/ch_watqual4.f90 index a80a79e..9a78b56 100644 --- a/src/ch_watqual4.f90 +++ b/src/ch_watqual4.f90 @@ -105,16 +105,6 @@ subroutine ch_watqual4 ht3%cbod = 1000. * ht1%cbod / ht1%flo ht3%dox = 1000. * ht1%dox / ht1%flo - !! ht5 is concentration from previous time step - ht5%orgn = 1000. * ob(icmd)%conc_prev%orgn / ht1%flo - ht5%sedp = 1000. * ob(icmd)%conc_prev%sedp / ht1%flo - ht5%no3 = 1000. * ob(icmd)%conc_prev%no3 / ht1%flo - ht5%solp = 1000. * ob(icmd)%conc_prev%solp / ht1%flo - ht5%chla = 1000. * ob(icmd)%conc_prev%chla / ht1%flo - ht5%nh3 = 1000. * ob(icmd)%conc_prev%nh3 / ht1%flo - ht5%no2 = 1000. * ob(icmd)%conc_prev%no2 / ht1%flo - ht5%cbod = 1000. * ob(icmd)%conc_prev%cbod / ht1%flo - ht5%dox = 1000. * ob(icmd)%conc_prev%dox / ht1%flo !! calculate temperature in stream Stefan and Preudhomme. 1993. Stream temperature estimation !! from air temperature. Water Res. Bull. p. 27-45 SWAT manual equation 2.3.13 @@ -123,6 +113,7 @@ subroutine ch_watqual4 ht2%temp = wtmp !! benthic sources/losses in mg + !ch_nut(jnut)%rs2 = 5. !!***jga rs2_s = Theta(ch_nut(jnut)%rs2,thrs2,wtmp) * ben_area !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt rs3_s = Theta(ch_nut(jnut)%rs3,thrs3,wtmp) * ben_area !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt rk4_s = Theta(ch_nut(jnut)%rk4,thrk4,wtmp) * ben_area !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt @@ -192,6 +183,7 @@ subroutine ch_watqual4 (ch_nut(jnut)%k_l + algi * (Exp(-lambda * rchdep)))) fll = 0.92 * (wgn_pms(iwgn)%daylth / 24.) * fl_1 + !ch_nut(jnut)%mumax = 3. !***jga !! calculcate local algal growth rate if (algcon < 5000.) then select case (ch_nut(jnut)%igropt) @@ -244,13 +236,13 @@ subroutine ch_watqual4 cbodo = min (ht3%cbod, ht3%dox) cbodoin = min (ht3%cbod, ht3%dox) rk1_k = -Theta (ch_nut(jnut)%rk1, thrk1,wtmp) - rk1_m = wq_k2m (tday, rt_delt, rk1_k, ht5%cbod, ht3%cbod) + rk1_m = wq_k2m (tday, rt_delt, rk1_k, ht3%cbod, ht3%cbod) !! calculate corresponding m-term rk3_k=0. if (rchdep > 0.001) rk3_k = -Theta (ch_nut(jnut)%rk3, thrk3, wtmp) / rchdep factm = rk1_m factk = rk3_k - ht3%cbod = wq_semianalyt (tday, rt_delt, factm, factk, ht5%cbod, ht3%cbod) + ht3%cbod = wq_semianalyt (tday, rt_delt, factm, factk, ht3%cbod, ht3%cbod) !! nitrogen calculations !! calculate organic N concentration at end of day @@ -262,10 +254,10 @@ subroutine ch_watqual4 rs4_k = 0. if (rchdep > 0.001) rs4_k = Theta (ch_nut(jnut)%rs4, thrs4, wtmp) / rchdep - bc3_m = wq_k2m (tday, rt_delt, -bc3_k, ht5%orgn, ht3%orgn) + bc3_m = wq_k2m (tday, rt_delt, -bc3_k, ht3%orgn, ht3%orgn) factk = -rs4_k factm = bc3_m - ht3%orgn = wq_semianalyt (tday, rt_delt, factm, factk, ht5%orgn, ht3%orgn) + ht3%orgn = wq_semianalyt (tday, rt_delt, factm, factk, ht3%orgn, ht3%orgn) if (ht3%orgn <0.) ht3%orgn = 0. !! calculate dissolved oxygen concentration if reach at end of day QUAL2E section 3.6 equation III-28 @@ -277,10 +269,10 @@ subroutine ch_watqual4 factk = - rk2_k bc2_k = -Theta (ch_nut(jnut)%bc2, thbc2, wtmp) - bc1_m = wq_k2m (tday, rt_delt, factk, ht5%nh3, ammoin) - bc2_m = wq_k2m (tday, rt_delt, bc2_k, ht5%no2, ht3%no2) + bc1_m = wq_k2m (tday, rt_delt, factk, ht3%nh3, ammoin) + bc2_m = wq_k2m (tday, rt_delt, bc2_k, ht3%no2, ht3%no2) factm = rk1_m + rk2_m - rs4_k + bc1_m * ch_nut(jnut)%ai5 + bc2_m * ch_nut(jnut)%ai6 - ht3%dox = wq_semianalyt (tday, rt_delt, factm, factk, ht5%dox, ht3%dox) + ht3%dox = wq_semianalyt (tday, rt_delt, factm, factk, ht3%dox, ht3%dox) if (ht3%dox <0.) ht3%dox = 0. !! end oxygen calculations @@ -288,53 +280,52 @@ subroutine ch_watqual4 !! calculate ammonia nitrogen concentration at end of day QUAL2E section 3.3.2 equation III-17 factk = -bc1_k factm = bc1_m - bc3_m - ht3%nh3 = wq_semianalyt (tday, rt_delt, factm, 0., ht5%nh3, ammoin) + ht3%nh3 = wq_semianalyt (tday, rt_delt, factm, 0., ht3%nh3, ammoin) if (ht3%nh3 < 1.e-6) ht3%nh3 = 0. !! calculate concentration of nitrite at end of day QUAL2E section 3.3.3 equation III-19 factm = -bc1_m + bc2_m - ht3%no2 = wq_semianalyt (tday, rt_delt, factm, 0., ht5%no2, ht3%no2) + ht3%no2 = wq_semianalyt (tday, rt_delt, factm, 0., ht3%no2, ht3%no2) if (ht3%no2 < 1.e-6) ht3%no2 = 0. !! calculate nitrate concentration at end of day QUAL2E section 3.3.4 equation III-20 factk = 0. factm = -bc2_m - ht3%no3 = wq_semianalyt (tday, rt_delt, factm, 0., ht5%no3, ht3%no3) + ht3%no3 = wq_semianalyt (tday, rt_delt, factm, 0., ht3%no3, ht3%no3) if (ht3%no3 < 1.e-6) ht3%no3 = 0. !! end nitrogen calculations !! phosphorus calculations !! calculate organic phosphorus concentration at end of day QUAL2E section 3.3.6 equation III-24 bc4_k = Theta (ch_nut(jnut)%bc4, thbc4,wtmp) - bc4_m = wq_k2m (tday, rt_delt, -bc4_k, ht5%sedp, ht3%sedp) + bc4_m = wq_k2m (tday, rt_delt, -bc4_k, ht3%sedp, ht3%sedp) rs5_k = 0. + !ch_nut(jnut)%rs5 = 0. ! ***jga if (rchdep > 0.001) rs5_k = Theta (ch_nut(jnut)%rs5, thrs5, wtmp) / rchdep factk = -rs5_k factm = bc4_m - ht3%sedp = wq_semianalyt (tday, rt_delt, factm, factk, ht5%sedp, ht3%sedp) + ht3%sedp = wq_semianalyt (tday, rt_delt, factm, factk, ht3%sedp, ht3%sedp) if (ht3%sedp < 1.e-6) ht3%sedp = 0. + !! calculate dissolved phosphorus concentration at end of day QUAL2E section 3.4.2 equation III-25 + !factk = 0. + !factm = -bc4_m + ch_nut(jnut)%ai2 * alg_m + !ht3%solp = wq_semianalyt (tday, rt_delt, factm, 0., ht3%solp, dispin) + !if (ht3%solp < 1.e-6) ht3%solp = 0. !! calculate dissolved phosphorus concentration at end of day QUAL2E section 3.4.2 equation III-25 factk = 0. factm = -bc4_m + ch_nut(jnut)%ai2 * alg_m - ht3%solp = wq_semianalyt (tday, rt_delt, factm, 0., ht5%solp, dispin) + !ht3%solp = wq_semianalyt (tday, rt_delt, factm, 0., ht5%solp, dispin) + xx = Theta (ch_nut(jnut)%bc4, thbc4,wtmp) * ht3%sedp + yy = Theta(ch_nut(jnut)%rs2, thrs2, wtmp) / (sd_chd(jrch)%chd) + zz = ch_nut(jnut)%ai2 * Theta(gra,thgra,wtmp) * algin + ht3%solp = ht3%solp + (xx + yy - zz) * tday if (ht3%solp < 1.e-6) ht3%solp = 0. !! end phosphorus calculations - !! save concentration for next time step - ob(icmd)%conc_prev%orgn = ht3%orgn * ht1%flo / 1000. - ob(icmd)%conc_prev%sedp = ht3%sedp * ht1%flo / 1000. - ob(icmd)%conc_prev%no3 = ht3%no3 * ht1%flo / 1000. - ob(icmd)%conc_prev%solp = ht3%solp * ht1%flo / 1000. - ob(icmd)%conc_prev%chla = ht3%chla * ht1%flo / 1000. - ob(icmd)%conc_prev%nh3 = ht3%nh3 * ht1%flo / 1000. - ob(icmd)%conc_prev%no2 = ht3%no2 * ht1%flo / 1000. - ob(icmd)%conc_prev%cbod = ht3%cbod * ht1%flo / 1000. - ob(icmd)%conc_prev%dox = ht3%dox * ht1%flo / 1000. - !! convert back from concentration to mass for routing ht2%orgn = ht3%orgn * ht1%flo / 1000. ht2%sedp = ht3%sedp * ht1%flo / 1000. diff --git a/src/channel_control.f90 b/src/channel_control.f90 index 3d8cb7e..97ff681 100644 --- a/src/channel_control.f90 +++ b/src/channel_control.f90 @@ -95,25 +95,25 @@ subroutine channel_control ch(jrch)%dep_chan = 0. sedrch = 0. rch_san = 0. - rch_cla = 0. rch_sil = 0. + rch_cla = 0. rch_sag = 0. - rch_gra = 0. rch_lag = 0. + rch_gra = 0. wtrin = 0. - algin = 0. chlin = 0. + algin = 0. orgnin = 0. - nitritin = 0. ammoin = 0. + nitritin = 0. nitratin = 0. orgpin = 0. dispin = 0. cbodin = 0. disoxin = 0. + cinn = 0. !! route water through reach rtwtr_d=0. - cinn = 0. rttlc_d=0. rtevp_d =0. @@ -186,16 +186,16 @@ subroutine channel_control !! Channel Deposition (Only new deposits during the current time step) if (ch(jrch)%depch >= ch(jrch)%depprch) then - ch_d(jrch)%ch_dep = ch(jrch)%depch - ch(jrch)%depprch - else - ch_d(jrch)%ch_dep = 0. - end if + ch_d(jrch)%ch_dep = ch(jrch)%depch - ch(jrch)%depprch + else + ch_d(jrch)%ch_dep = 0. + end if !! Floodplain Deposition (Only new deposits during the current time step) if (ch(jrch)%depfp >= ch(jrch)%depprfp) then - ch_d(jrch)%fp_dep = ch(jrch)%depfp - ch(jrch)%depprfp - else - ch_d(jrch)%fp_dep = 0. - end if + ch_d(jrch)%fp_dep = ch(jrch)%depfp - ch(jrch)%depprfp + else + ch_d(jrch)%fp_dep = 0. + end if !! Total suspended sediments (only silt and clay) if (ch_sed(jsed)%eqn == 0) then ch_d(jrch)%tot_ssed = sedrch diff --git a/src/cli_precip_control.f90 b/src/cli_precip_control.f90 index 6c90e3d..2582759 100644 --- a/src/cli_precip_control.f90 +++ b/src/cli_precip_control.f90 @@ -89,16 +89,16 @@ subroutine cli_precip_control (istart) do ist = 1, time%step wst(iwst)%weat%ts_next(ist) = pcp(ipg)%tss(ist,cur_day,time%yrs) if (wst(iwst)%weat%ts_next(ist) <= -97.) then - !! simulate missing data - call cli_pgen(iwgn) - call cli_pgenhr - exit - end if - wst(iwst)%weat%precip_next = wst(iwst)%weat%precip_next + wst(iwst)%weat%ts_next(ist) + !! simulate missing data + call cli_pgen(iwgn) + call cli_pgenhr + exit + end if + wst(iwst)%weat%precip_next = wst(iwst)%weat%precip_next + wst(iwst)%weat%ts_next(ist) end do wst(iwst)%weat%precip_next = sum (pcp(ipg)%tss(:,cur_day,time%yrs)) else - !! daily precip + !! daily precip if (out_bounds == "y") then wst(iwst)%weat%precip_next = -98. else @@ -109,7 +109,7 @@ subroutine cli_precip_control (istart) if (wst(iwst)%weat%precip_next <= -97.) then call cli_pgen(iwgn) pcp(ipg)%days_gen = pcp(ipg)%days_gen + 1 - end if + end if end if end if diff --git a/src/cli_read_atmodep_cs.f90 b/src/cli_read_atmodep_cs.f90 index 2322c97..f5ddfe2 100644 --- a/src/cli_read_atmodep_cs.f90 +++ b/src/cli_read_atmodep_cs.f90 @@ -79,7 +79,7 @@ subroutine cli_read_atmodep_cs read(5050,*) (atmodep_cs(iadep)%cs(ics)%drymo(imo),imo=1,atmodep_cont%num) enddo end if - + !yearly values if (atmodep_cont%timestep == "yr") then read(5050,*) station_name !station name diff --git a/src/cli_read_atmodep_salt.f90 b/src/cli_read_atmodep_salt.f90 index 50000d0..83c3e74 100644 --- a/src/cli_read_atmodep_salt.f90 +++ b/src/cli_read_atmodep_salt.f90 @@ -77,7 +77,7 @@ subroutine cli_read_atmodep_salt read(5050,*) salt_ion,(atmodep_salt(iadep)%salt(isalt)%drymo(imo),imo=1,atmodep_cont%num) enddo end if - + !yearly values if (atmodep_cont%timestep == "yr") then read(5050,*) station_name !station name diff --git a/src/climate_control.f90 b/src/climate_control.f90 index 889e258..48c4210 100644 --- a/src/climate_control.f90 +++ b/src/climate_control.f90 @@ -211,9 +211,9 @@ subroutine climate_control xl = 2.501 - 2.361e-3 * wst(iwst)%weat%tave wst(iwst)%weat%pet = .0023 * (ramm / xl) * (wst(iwst)%weat%tave & + 17.8) * (wst(iwst)%weat%tmax - wst(iwst)%weat%tmin) ** 0.5 - wst(iwst)%weat%pet = Max(0., wst(iwst)%weat%pet) + wst(iwst)%weat%pet = Max(0.01, wst(iwst)%weat%pet) else - wst(iwst)%weat%pet = 0. + wst(iwst)%weat%pet = 0.01 endif if (wst(iwst)%weat%pet > 0.1) then wst(iwst)%weat%ppet = wst(iwst)%weat%ppet + wst(iwst)%weat%precip / wst(iwst)%weat%pet diff --git a/src/climate_module.f90 b/src/climate_module.f90 index 6670016..43c5fbb 100644 --- a/src/climate_module.f90 +++ b/src/climate_module.f90 @@ -120,7 +120,7 @@ module climate_module character (len=50) :: sgage = "" !! gage name for solar radiation character (len=50) :: hgage = "" !! gage name for relative humidity character (len=50) :: wgage = "" !! gage name for windspeed - character (len=50) :: petgage = "" !! name of pet gage ? + character (len=50) :: petgage = "" !! name of pet gage character (len=50) :: atmodep = "" !! atmospheric depostion data file locator end type weather_codes_station_char diff --git a/src/command.f90 b/src/command.f90 index a1e5be6..ff8402a 100644 --- a/src/command.f90 +++ b/src/command.f90 @@ -112,6 +112,11 @@ subroutine command if (cs_db%num_tot > 0 .and. obcs_alloc(icmd).eq.1) then obcs(icmd)%hin_sur(1) = obcs(icmd)%hin_sur(1) + frac_in * obcs(iob)%hd(3) end if + ! add to tile flow + ob(icmd)%hin_til = ob(icmd)%hin_til + frac_in * ob(iob)%hd(5) + if (cs_db%num_tot > 0 .and. obcs_alloc(icmd).eq.1) then + obcs(icmd)%hin_til(1) = obcs(icmd)%hin_til(1) + frac_in * obcs(iob)%hd(5) + end if ! add to lateral soil runon ob(icmd)%hin_lat = ob(icmd)%hin_lat + frac_in * ob(iob)%hd(4) if (cs_db%num_tot > 0 .and. obcs_alloc(icmd).eq.1) then @@ -618,7 +623,7 @@ subroutine command enddo 102 format(i6,11x,i3,8x,i5,5x,1000(f16.4)) -103 format(4i6,2i8,2x,a,35f12.3) +!*** tu Wunused-label: 103 format(4i6,2i8,2x,a,35f12.3) return diff --git a/src/conditional_module.f90 b/src/conditional_module.f90 index 523f2c7..c5241b6 100644 --- a/src/conditional_module.f90 +++ b/src/conditional_module.f90 @@ -18,7 +18,7 @@ module conditional_module character(len=25) :: ob = "" ! object variable (ie res, hru, canal, etc) integer :: ob_num = 0 ! object number character(len=25) :: name = "" ! name of action - character(len=25) :: option = "" ! action option - specific to type of action (ie for reservoir, option to + character(len=40) :: option = "" ! action option - specific to type of action (ie for reservoir, option to ! input rate, days of drawdown, weir equation pointer, etc real :: const = 0. ! constant used for rate, days, etc real :: const2 = 1 ! additional constant used for rate, days, etc @@ -33,6 +33,7 @@ module conditional_module type (conditions_var), dimension(:), allocatable :: cond ! conditions character(len=25), dimension(:,:), allocatable :: alt ! condition alternatives type (actions_var), dimension(:), allocatable :: act ! actions + integer, dimension(:), allocatable :: lu_chg_mx ! max times lu change can occur character(len=1), dimension(:,:), allocatable :: act_outcomes ! action outcomes ("y" to perform action; "n" to not perform) character(len=1), dimension(:), allocatable :: act_hit ! "y" if all condition alternatives (rules) are met; "n" if not integer, dimension(:), allocatable :: act_typ ! pointer to action type (ie plant, fert type, tillage implement, release type, etc) diff --git a/src/conditions.f90 b/src/conditions.f90 index 507984c..8afbdff 100644 --- a/src/conditions.f90 +++ b/src/conditions.f90 @@ -191,7 +191,7 @@ subroutine conditions (ob_cur, idtbl) ipl = Max (Int(d_tbl%cond(ic)%lim_const), 1) do ialt = 1, d_tbl%alts if (d_tbl%alt(ic,ialt) == "=") then !determine if growing (y) or not (n) - if (pcom(ob_num)%plcur(ipl)%gro /= d_tbl%cond(ic)%lim_var) then + if (pcom(ob_num)%plcur(ipl)%gro == "n") then d_tbl%act_hit(ialt) = "n" end if end if @@ -343,6 +343,12 @@ subroutine conditions (ob_cur, idtbl) ivar_tbl = int(d_tbl%cond(ic)%lim_const) call cond_integer (ic, ivar_cur, ivar_tbl) + !sequential year of simulation + case ("year_start") + ivar_cur = time%yrc_start + ivar_tbl = int(d_tbl%cond(ic)%lim_const) + call cond_integer (ic, ivar_cur, ivar_tbl) + !current years of maturity for perennial plants case ("cur_yrs_mat") ob_num = d_tbl%cond(ic)%ob_num @@ -450,12 +456,12 @@ subroutine conditions (ob_cur, idtbl) do ialt = 1, d_tbl%alts if (d_tbl%alt(ic,ialt) == "=") then - if (hru(ob_num)%tiledrain /= Int(d_tbl%cond(ic)%lim_const)) then + if (hru(ob_num)%tiledrain == 0) then d_tbl%act_hit(ialt) = "n" end if end if if (d_tbl%alt(ic,ialt) == "/") then - if (hru(ob_num)%tiledrain == Int(d_tbl%cond(ic)%lim_const)) then + if (hru(ob_num)%tiledrain == 1) then d_tbl%act_hit(ialt) = "n" end if end if @@ -643,6 +649,17 @@ subroutine conditions (ob_cur, idtbl) end if end do + !calibration group in landuse.lum - ie: cropland, urban, forest, etc + case ("cal_group") + ob_num = d_tbl%cond(ic)%ob_num + if (ob_num == 0) ob_num = ob_cur + do ialt = 1, d_tbl%alts + if (d_tbl%alt(ic,ialt) == "=") then + if (hru(ob_num)%cal_group /= d_tbl%cond(ic)%lim_var) then + d_tbl%act_hit(ialt) = "n" + end if + end if + end do !tillage system - name of tillage decision table in lum.dtl case ("tillage") ob_num = d_tbl%cond(ic)%ob_num @@ -663,7 +680,7 @@ subroutine conditions (ob_cur, idtbl) end do !plants - if plant is in the cummunity - case ("plant") + case ("plant_com") ob_num = d_tbl%cond(ic)%ob_num if (ob_num == 0) ob_num = ob_cur @@ -692,7 +709,7 @@ subroutine conditions (ob_cur, idtbl) end do !channel management - case ("ch_use") + case ("ch_order") ob_num = d_tbl%cond(ic)%ob_num if (ob_num == 0) ob_num = ob_cur @@ -724,6 +741,8 @@ subroutine conditions (ob_cur, idtbl) targ = targ_val + 10000. * d_tbl%cond(ic)%lim_const case ("-") targ = targ_val - 10000. * d_tbl%cond(ic)%lim_const !convert ha-m to m3 + case ("/") + targ = targ_val / d_tbl%cond(ic)%lim_const end select case ("evol") !emergency storage volume targ_val = res_ob(ires)%evol @@ -735,6 +754,8 @@ subroutine conditions (ob_cur, idtbl) targ = targ_val + 10000. * d_tbl%cond(ic)%lim_const case ("-") targ = targ_val - 10000. * d_tbl%cond(ic)%lim_const !convert ha-m to m3 + case ("/") + targ = targ_val / d_tbl%cond(ic)%lim_const end select end select @@ -749,20 +770,15 @@ subroutine conditions (ob_cur, idtbl) iob = sp_ob1%res + ob_num - 1 flo_m3 = ob(iob)%hin%flo / 86400. call cond_real (ic, flo_m3, d_tbl%cond(ic)%lim_const, idtbl) - - !impounded water depth -paddy average water depth of water + !impounded water depth -paddy average water depth case ("wet_depth") !determine target variable ires = d_tbl%cond(ic)%ob_num if (ires == 0) ires = ob_cur - !set limit constant if comparing to weir height - if (d_tbl%cond(ic)%lim_var == "hwater") then - targ = d_tbl%cond(ic)%lim_const/1000. !m - else - targ = wet_ob(ires)%weir_hgt - end if + !convert depth to m + targ = d_tbl%cond(ic)%lim_const/1000. !check alternatives call cond_real (ic, wet_ob(ires)%depth, targ, idtbl) @@ -773,8 +789,8 @@ subroutine conditions (ob_cur, idtbl) ires = d_tbl%cond(ic)%ob_num if (ires == 0) ires = ob_cur - !set limit constant if comparing to weir height - targ = d_tbl%cond(ic)%lim_const/1000. !m + !convert depth to m + targ = d_tbl%cond(ic)%lim_const/1000. !check alternatives call cond_real (ic, wet_ob(ires)%weir_hgt, targ, idtbl) diff --git a/src/constituent_mass_module.f90 b/src/constituent_mass_module.f90 index b77313b..41bd6a5 100644 --- a/src/constituent_mass_module.f90 +++ b/src/constituent_mass_module.f90 @@ -596,9 +596,9 @@ function hydcsout_add (hydcs1, hydcs2) result (hydcs3) integer :: ics = 0 allocate (hydcs3%pest(cs_db%num_pests), source = 0.) allocate (hydcs3%path(cs_db%num_paths), source = 0.) + allocate (hydcs3%hmet(cs_db%num_metals), source = 0.) allocate (hydcs3%salt(cs_db%num_salts), source = 0.) allocate (hydcs3%cs(cs_db%num_cs), source = 0.) - allocate (hydcs3%hmet(cs_db%num_metals), source = 0.) do ipest = 1, cs_db%num_pests hydcs3%pest(ipest) = hydcs2%pest(ipest) + hydcs1%pest(ipest) @@ -629,10 +629,10 @@ function hydcsout_mult_const (const, hydcs1) result (hydcs2) integer :: ics = 0 allocate (hydcs2%pest(cs_db%num_pests), source = 0.) allocate (hydcs2%path(cs_db%num_paths), source = 0.) + allocate (hydcs2%hmet(cs_db%num_metals), source = 0.) allocate (hydcs2%salt(cs_db%num_salts), source = 0.) - allocate (hydcs2%cs(cs_db%num_cs), source = 0.) !rtb cs - allocate (hydcs2%hmet(cs_db%num_metals), source = 0.) + allocate (hydcs2%cs(cs_db%num_cs), source = 0.) !rtb cs do ipest = 1, cs_db%num_pests hydcs2%pest(ipest) = const * hydcs1%pest(ipest) diff --git a/src/cs_balance.f90 b/src/cs_balance.f90 index 335db27..3417cce 100644 --- a/src/cs_balance.f90 +++ b/src/cs_balance.f90 @@ -682,14 +682,14 @@ subroutine cs_balance !rtb cs gwsol_ss(i)%solute(sol_index)%sorb = 0. enddo sol_index = sol_index + 1 - enddo !go to next constituent + enddo !go to next constituent endif endif 7000 format(i8,i8,i8,100e16.8) -7001 format(20e16.8) -7002 format(i8,50f16.8) +!*** tu Wunused-label: 7001 format(20e16.8) +!*** tu Wunused-label: 7002 format(i8,50f16.8) return end \ No newline at end of file diff --git a/src/cs_divert.f90 b/src/cs_divert.f90 index 4f09489..18ffe30 100644 --- a/src/cs_divert.f90 +++ b/src/cs_divert.f90 @@ -45,7 +45,7 @@ subroutine cs_divert(iwallo,idmd,dem_id) !rtb cs !determine number of water sources nsource = wallo(iwallo)%dmd(idmd)%dmd_src_obs - + !demand object type obj_type_dem = wallo(iwallo)%dmd(idmd)%rcv_ob diff --git a/src/cs_lch.f90 b/src/cs_lch.f90 index 6f1057b..e85c6a1 100644 --- a/src/cs_lch.f90 +++ b/src/cs_lch.f90 @@ -106,7 +106,7 @@ subroutine cs_lch !rtb cs ro_mass = surfq(j) * cosurfcs ro_mass = Min(ro_mass, cs_soil(j)%ly(jj)%cs(ics)) cs_soil(j)%ly(jj)%cs(ics) = cs_soil(j)%ly(jj)%cs(ics) - ro_mass - surqcs(j,ics) = ro_mass + surqcs(j,ics) = ro_mass endif !Daniel 1/2012 @@ -155,7 +155,7 @@ subroutine cs_lch !rtb cs hru_area_m2 = hru(j)%area_ha * 10000. !ha --> m2 water_volume = (soil(j)%phys(jj)%st/1000.) * hru_area_m2 if(cs_soil(j)%ly(jj)%cs(ics).lt.0) then - cs_soil(j)%ly(jj)%cs(ics) = 0. + cs_soil(j)%ly(jj)%cs(ics) = 0. endif cs_mass_kg = cs_soil(j)%ly(jj)%cs(ics) * hru(j)%area_ha !kg !calculate concentration in mg/L diff --git a/src/dtbl_scen_read.f90 b/src/dtbl_scen_read.f90 index 4926b78..3bffe2a 100644 --- a/src/dtbl_scen_read.f90 +++ b/src/dtbl_scen_read.f90 @@ -51,6 +51,8 @@ subroutine dtbl_scen_read allocate (dtbl_scen(i)%act_hit(dtbl_scen(i)%alts)) allocate (dtbl_scen(i)%act_typ(dtbl_scen(i)%acts), source = 0) allocate (dtbl_scen(i)%act_app(dtbl_scen(i)%acts), source = 0) + allocate (dtbl_scen(i)%lu_chg_mx(dtbl_scen(i)%acts), source = 0) + allocate (dtbl_scen(i)%act_outcomes(dtbl_scen(i)%acts,dtbl_scen(i)%alts)) !read conditions and condition alternatives diff --git a/src/ero_ovrsed.f90 b/src/ero_ovrsed.f90 index 658eea6..1827630 100644 --- a/src/ero_ovrsed.f90 +++ b/src/ero_ovrsed.f90 @@ -11,7 +11,7 @@ subroutine ero_ovrsed() !! hru_km(:) |km2 |area of HRU in square kilometers !! rwst(:)%weat%ts(:) |mm H2O |precipitation for the time step during the !! |day in HRU -!! eros_spl |none |coefficient of splash erosion varing 0.9-3.1 +!! eros_spl |none |coefficient of splash erosion varing 0.9-3.1 !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ @@ -25,8 +25,8 @@ subroutine ero_ovrsed() !! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! jj |none |HRU number -!! kk |none |time step of the day +!! jj |none |HRU number +!! kk |none |time step of the day !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ @@ -35,7 +35,7 @@ subroutine ero_ovrsed() !! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ !! Splash erosion model is adopted from EUROSEM model developed by Morgan (2001). -!! Rill/interill erosion model is adoped from Modified ANSWERS model by Park et al.(1982) +!! Rill/interill erosion model is adoped from Modified ANSWERS model by Park et al.(1982) !! Code developed by J. Jeong and N. Kannan, BRC. use urban_data_module @@ -73,114 +73,114 @@ subroutine ero_ovrsed() real :: rintnsty = 0. !mm/hr |rainfall intensity real :: cover = 0. !kg/ha |soil cover - j = ihru - ulu = hru(j)%luse%urb_lu + j = ihru + ulu = hru(j)%luse%urb_lu !! Fraction of sand percent_clay = soil(j)%phys(1)%clay - percent_silt = soil(j)%phys(1)%silt - percent_sand = 100. - percent_clay - percent_silt + percent_silt = soil(j)%phys(1)%silt + percent_sand = 100. - percent_clay - percent_silt !! Soil detachability values adopted from EUROSEM User Guide (Table 1) - if ((percent_clay>=40.) .and. (percent_sand>=20.) .and. & + if ((percent_clay>=40.) .and. (percent_sand>=20.) .and. & (percent_sand<=45.)) then - erod_k = 2.0 !clay + erod_k = 2.0 !clay elseif ((percent_clay>=27.) .and. (percent_sand>=20.) .and. & (percent_sand<=45.)) then - erod_k = 1.7 !Clay loam + erod_k = 1.7 !Clay loam elseif ((percent_silt<=40.).and.(percent_sand<=20.)) then - erod_k = 2.0 !Clay + erod_k = 2.0 !Clay elseif ((percent_silt>40.).and.(percent_clay>=40.)) then - erod_k = 1.6 !Silty clay + erod_k = 1.6 !Silty clay elseif ((percent_clay>=35.).and.(percent_sand>=45.)) then - erod_k = 1.9 !Sandy clay + erod_k = 1.9 !Sandy clay elseif ((percent_clay>=27.).and.(percent_sand<20.)) then - erod_k = 1.6 !Silty clay loam + erod_k = 1.6 !Silty clay loam elseif ((percent_clay<=10.).and.(percent_silt>=80.)) then - erod_k = 1.2 !Silt + erod_k = 1.2 !Silt elseif (percent_silt>=50.) then - erod_k = 1.5 !Silt loam + erod_k = 1.5 !Silt loam elseif ((percent_clay>=7.) .and. (percent_sand<=52.) .and. & (percent_silt>=28.)) then - erod_k = 2.0 !Loam + erod_k = 2.0 !Loam elseif (percent_clay>=20.) then - erod_k = 2.1 !Sandy clay loam + erod_k = 2.1 !Sandy clay loam elseif (percent_clay>=percent_sand-70.) then - erod_k = 2.6 !Sandy loam + erod_k = 2.6 !Sandy loam elseif (percent_clay>=(2. * percent_sand) - 170.) then - erod_k = 3.0 !Loamy sand + erod_k = 3.0 !Loamy sand else - erod_k = 1.9 !Sand + erod_k = 1.9 !Sand end if - - !! canopy cover based on leaf area index -!! canopy cover is assumed to be 100% if LAI>=1 - if(pcom(j)%lai_sum >= 1.) then - canopy_cover = 1. - else - canopy_cover = pcom(j)%lai_sum + + !! canopy cover based on leaf area index +!! canopy cover is assumed to be 100% if LAI>=1 + if(pcom(j)%lai_sum >= 1.) then + canopy_cover = 1. + else + canopy_cover = pcom(j)%lai_sum end if if (bsn_cc%gampt > 0) then do k = 1, time%step - rintnsty = 60. * wst(iwst)%weat%ts(k) / Real(time%dtm) - rain_d50 = 0.188 * rintnsty ** 0.182 + rintnsty = 60. * wst(iwst)%weat%ts(k) / Real(time%dtm) + rain_d50 = 0.188 * rintnsty ** 0.182 - if (rintnsty > 0) then - + if (rintnsty > 0) then + !! Rainfall kinetic energy generated by direct throughfall (J/m^2/mm) - ke_direct = 8.95 + 8.44 * log10(rintnsty) + ke_direct = 8.95 + 8.44 * log10(rintnsty) if(ke_direct<0.) ke_direct = 0. - !! Rainfall kinetic energy generated by leaf drainage (J/m^2) - pheff = 0.5 * pcom(j)%cht_mx - ke_leaf = 15.8 * pheff ** 0.5 - 5.87 - if (ke_leaf<0) ke_leaf = 0. - - !! Depth of rainfall - rdepth_tot = wst(iwst)%weat%ts(k) / (time%dtm * 60.) - rdepth_leaf = rdepth_tot * canopy_cover - rdepth_direct = rdepth_tot - rdepth_leaf - else - ke_direct = 0. - ke_leaf = 0. - rdepth_tot = 0. - rdepth_leaf = 0. - rdepth_direct = 0. - endif - - !! total kinetic energy by rainfall (J/m^2) - ke_total = 0.001 * (rdepth_direct * ke_direct + rdepth_leaf * ke_leaf) - - !! total soil detachment by raindrop impact - sedspl = erod_k * ke_total * exp(-bsn_prm%eros_spl * & + !! Rainfall kinetic energy generated by leaf drainage (J/m^2) + pheff = 0.5 * pcom(j)%cht_mx + ke_leaf = 15.8 * pheff ** 0.5 - 5.87 + if (ke_leaf<0) ke_leaf = 0. + + !! Depth of rainfall + rdepth_tot = wst(iwst)%weat%ts(k) / (time%dtm * 60.) + rdepth_leaf = rdepth_tot * canopy_cover + rdepth_direct = rdepth_tot - rdepth_leaf + else + ke_direct = 0. + ke_leaf = 0. + rdepth_tot = 0. + rdepth_leaf = 0. + rdepth_direct = 0. + endif + + !! total kinetic energy by rainfall (J/m^2) + ke_total = 0.001 * (rdepth_direct * ke_direct + rdepth_leaf * ke_leaf) + + !! total soil detachment by raindrop impact + sedspl = erod_k * ke_total * exp(-bsn_prm%eros_spl * & hhqday(j,k) / 1000.) * hru(j)%km ! tons - !! Impervious area of HRU - if(hru(j)%luse%urb_lu > 0) sedspl = sedspl * (1.- urbdb(ulu)%fimp) + !! Impervious area of HRU + if(hru(j)%luse%urb_lu > 0) sedspl = sedspl * (1.- urbdb(ulu)%fimp) - !! maximum water depth that allows splash erosion - if(hhqday(j,k)>=3.* rain_d50.or.hhqday(j,k)<=1.e-3) sedspl = 0. + !! maximum water depth that allows splash erosion + if(hhqday(j,k)>=3.* rain_d50.or.hhqday(j,k)<=1.e-3) sedspl = 0. - !! Overland flow erosion + !! Overland flow erosion !! cover and management factor used in usle equation (ysed.f) cover = pl_mass(j)%ab_gr_com%m + rsd1(j)%tot_com%m - c = Exp((-.2231 - cvm_com(j)) * Exp(-.00115 * cover) + cvm_com(j)) - !! specific weight of water at 5 centigrate =9807N/m3 - bed_shear = 9807 * (hhqday(j,k) / 1000.) * hru(j)%topo%slope ! N/m2 - sedov = 11.02 * bsn_prm%rill_mult * soil(j)%ly(1)%usle_k * & + c = Exp((-.2231 - cvm_com(j)) * Exp(-.00115 * cover) + cvm_com(j)) + !! specific weight of water at 5 centigrate =9807N/m3 + bed_shear = 9807 * (hhqday(j,k) / 1000.) * hru(j)%topo%slope ! N/m2 + sedov = 11.02 * bsn_prm%rill_mult * soil(j)%ly(1)%usle_k * & bsn_prm%c_factor * c * bed_shear ** bsn_prm%eros_expo ! kg/hour/m2 - if (time%step > 1) then - sedov = 16.667 * sedov * hru(j)%km * time%dtm ! tons per time step - else - sedov = 24000. * sedov * hru(j)%km ! tons per day - end if + if (time%step > 1) then + sedov = 16.667 * sedov * hru(j)%km * time%dtm ! tons per time step + else + sedov = 24000. * sedov * hru(j)%km ! tons per day + end if - !! Impervious area of HRU - if (hru(j)%luse%urb_lu > 0) sedov = sedov * (1.- urbdb(ulu)%fimp) + !! Impervious area of HRU + if (hru(j)%luse%urb_lu > 0) sedov = sedov * (1.- urbdb(ulu)%fimp) - hhsedy(j,k) = (sedspl + sedov) - if (hhsedy(j,k) < 1.e-10) hhsedy(j,k) = 0. + hhsedy(j,k) = (sedspl + sedov) + if (hhsedy(j,k) < 1.e-10) hhsedy(j,k) = 0. end do end if diff --git a/src/exco_read_om.f90 b/src/exco_read_om.f90 index cf65aab..922a010 100644 --- a/src/exco_read_om.f90 +++ b/src/exco_read_om.f90 @@ -42,7 +42,7 @@ subroutine exco_read_om db_mx%exco_om = imax - allocate (exco(0:imax)) ! + allocate (exco(0:imax)) !! change to exco_om allocate (exco_om_num(0:imax), source = 0) allocate (exco_om_name(0:imax)) rewind (107) diff --git a/src/gwflow_chan_read.f90 b/src/gwflow_chan_read.f90 index d401284..2c6be53 100644 --- a/src/gwflow_chan_read.f90 +++ b/src/gwflow_chan_read.f90 @@ -10,7 +10,7 @@ subroutine gwflow_chan_read implicit none - character(len=8) :: col_head_con(17) = "" + character(len=20) :: col_head_con(17) = "" integer :: i = 0 integer :: j = 0 integer :: k = 0 diff --git a/src/gwflow_chem.f90 b/src/gwflow_chem.f90 index e6a081a..62b4e32 100644 --- a/src/gwflow_chem.f90 +++ b/src/gwflow_chem.f90 @@ -39,17 +39,17 @@ subroutine gwflow_chem(cell_id,gw_vol) !rtb gwflow mass_rct = 0. !no3 - mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day + mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day !p sol_index = sol_index + 1 - mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day + mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day !salt ions if (gwsol_salt == 1) then do isalt=1,cs_db%num_salts sol_index = sol_index + 1 - mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day + mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day enddo endif @@ -107,7 +107,7 @@ subroutine gwflow_chem(cell_id,gw_vol) !rtb gwflow !boron sol_index = sol_index + 1 - mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day + mass_rct(sol_index) = gwsol_state(cell_id)%solute(sol_index)%conc * gw_vol * gwsol_rctn(sol_index) !g/day endif !if constituents are active diff --git a/src/gwflow_module.f90 b/src/gwflow_module.f90 index d3411b5..7afabb9 100644 --- a/src/gwflow_module.f90 +++ b/src/gwflow_module.f90 @@ -146,7 +146,7 @@ module gwflow_module real, dimension (:), allocatable :: gw_delay ! | real, dimension (:), allocatable :: gw_rech ! | real, dimension (:), allocatable :: delay ! | - + !gwet: variables for groundwater evapotranspiration ----------------------------------------- integer :: gw_et_flag = 0 ! | real, dimension (:), allocatable :: etremain ! | diff --git a/src/gwflow_read.f90 b/src/gwflow_read.f90 index 9151681..a824455 100644 --- a/src/gwflow_read.f90 +++ b/src/gwflow_read.f90 @@ -323,7 +323,7 @@ subroutine gwflow_read gw_state(i)%xcrd = 0. gw_state(i)%ycrd = 0. gw_state(i)%area = 0. - gw_state(i)%init = 0. + gw_state(i)%init = 0. gw_state(i)%head = 0. gw_state(i)%hydc = 0. gw_state(i)%spyd = 0. @@ -532,7 +532,7 @@ subroutine gwflow_read gw_state(i)%xcrd = 0. gw_state(i)%ycrd = 0. gw_state(i)%area = 0. - gw_state(i)%init = 0. + gw_state(i)%init = 0. gw_state(i)%head = 0. gw_state(i)%hydc = 0. gw_state(i)%spyd = 0. @@ -1929,7 +1929,7 @@ subroutine gwflow_read write(out_gwbal,*) 'ppex: mm groundwater pumping specified by user' write(out_gwbal,*) 'tile: mm groundwater removed via tile drains' write(out_gwbal,*) 'resv: mm groundwater exchanged with reservoirs' - write(out_gwbal,*) 'wetl: mm groundwater outflow to wetlands' + write(out_gwbal,*) 'wetl: mm groundwater outflow to wetlands' write(out_gwbal,*) 'canl: mm canal seepage to groundwater' write(out_gwbal,*) 'fpln: mm floodplain exchange' write(out_gwbal,*) 'error: -- water balance error for aquifer' @@ -2427,7 +2427,7 @@ subroutine gwflow_read write(out_hyd_sep,*) 'chan_satexsw: channel flow contributed from saturation excess runoff' write(out_hyd_sep,*) 'chan_tile: channel flow contributed from tile drain flow' write(out_hyd_sep,*) - hydsep_hdr = [character(len=16) :: " year"," day","channel","chan_surf","chan_lat","chan_gwsw","chan_swgw", & + hydsep_hdr = [character(len=12) :: " year"," day","channel","chan_surf","chan_lat","chan_gwsw","chan_swgw", & "chan_satexgw","chan_satexsw","chan_tile"] write(out_hyd_sep,121) (hydsep_hdr(j),j=1,10) @@ -2440,14 +2440,14 @@ subroutine gwflow_read return -100 format(i6,i6,10(f10.2)) +!*** tu Wunused-label: 100 format(i6,i6,10(f10.2)) !output files for all cells !101 format((f12.4)) !102 format((i4)) 101 format(f12.4) -102 format(i4) +!*** tu Wunused-label: 102 format(i4) !other formats -103 format(10000(i8)) +!*** tu Wunused-label: 103 format(10000(i8)) 111 format(1x,a, 5x,"Time",2x,i2,":",i2,":",i2) 119 format(4x,a8,a8,a10,a16,a19,50(a13)) 120 format(a8,50(a13)) diff --git a/src/gwflow_resv.f90 b/src/gwflow_resv.f90 index bf1bd0a..b895515 100644 --- a/src/gwflow_resv.f90 +++ b/src/gwflow_resv.f90 @@ -59,10 +59,10 @@ subroutine gwflow_resv(res_id) !rtb gwflow conn_length = sqrt(min_area) !exchange volume (m3/day) using Darcy's Law - head_diff = gw_resv_info(res_id)%elev(k) - gw_state(cell_id)%head + head_diff = gw_resv_info(res_id)%elev(k) - gw_state(cell_id)%head res_K = gw_resv_info(res_id)%hydc(k) res_thick = gw_resv_info(res_id)%thck(k) - Q = res_K * (head_diff / res_thick) * (res_thick * conn_length) + Q = res_K * (head_diff / res_thick) * (res_thick * conn_length) !check against available storage volumes (m3) if(Q > 0) then !reservoir --> aquifer @@ -73,9 +73,9 @@ subroutine gwflow_resv(res_id) !rtb gwflow !if((Q*-1 == 1).ge.gw_state(cell_id)%stor) then if (-Q .ge.gw_state(cell_id)%stor) then !Q = gw_state(cell_id)%stor * (-1) - Q = -gw_state(cell_id)%stor - gw_state(cell_id)%stor = gw_state(cell_id)%stor + Q - endif + Q = -gw_state(cell_id)%stor + gw_state(cell_id)%stor = gw_state(cell_id)%stor + Q + endif endif !store for gwflow water balance calculations (in gwflow_simulate) diff --git a/src/gwflow_simulate.f90 b/src/gwflow_simulate.f90 index 304a411..7b1367c 100644 --- a/src/gwflow_simulate.f90 +++ b/src/gwflow_simulate.f90 @@ -1555,7 +1555,7 @@ subroutine gwflow_simulate write(out_gw_res,101) (grid_val(i,j),j=1,grid_ncol) enddo else - write(out_gw_res,121) (gw_ss_sum(i)%resv,i=1,ncell) + write(out_gw_res,121) (gw_ss_sum(i)%resv,i=1,ncell) endif write(out_gw_res,*) if (gw_solute_flag == 1) then !solute mass flux @@ -1582,7 +1582,7 @@ subroutine gwflow_simulate endif !groundwater-wetland exchange if (gw_wet_flag == 1) then - write(out_gw_wet,*) 'Groundwater outflow to wetlands for:',time%yrc + write(out_gw_wet,*) 'Groundwater outflow to wetlands for:',time%yrc if(grid_type == "structured") then grid_val = 0. do i=1,grid_nrow @@ -1596,7 +1596,7 @@ subroutine gwflow_simulate write(out_gw_wet,101) (grid_val(i,j),j=1,grid_ncol) enddo else - write(out_gw_wet,121) (gw_ss_sum(i)%wetl,i=1,ncell) + write(out_gw_wet,121) (gw_ss_sum(i)%wetl,i=1,ncell) endif write(out_gw_wet,*) if (gw_solute_flag == 1) then !solute mass flux @@ -1622,8 +1622,8 @@ subroutine gwflow_simulate endif endif !groundwater-canal exchange - if (gw_canal_flag == 1) then - write(out_gw_canal,*) 'Groundwater-Canal Exchange Volumes for:',time%yrc + if (gw_canal_flag == 1) then + write(out_gw_canal,*) 'Groundwater-Canal Exchange Volumes for:',time%yrc if(grid_type == "structured") then grid_val = 0. do i=1,grid_nrow @@ -1637,7 +1637,7 @@ subroutine gwflow_simulate write(out_gw_canal,101) (grid_val(i,j),j=1,grid_ncol) enddo else - write(out_gw_canal,121) (gw_ss_sum(i)%canl,i=1,ncell) + write(out_gw_canal,121) (gw_ss_sum(i)%canl,i=1,ncell) endif write(out_gw_canal,*) if (gw_solute_flag == 1) then !solute mass flux @@ -1664,7 +1664,7 @@ subroutine gwflow_simulate endif !floodplain exchange if (gw_fp_flag == 1) then - write(out_gw_fp,*) 'Floodplain Exchange Volumes for:',time%yrc + write(out_gw_fp,*) 'Floodplain Exchange Volumes for:',time%yrc if(grid_type == "structured") then grid_val = 0. do i=1,grid_nrow @@ -1678,7 +1678,7 @@ subroutine gwflow_simulate write(out_gw_fp,101) (grid_val(i,j),j=1,grid_ncol) enddo else - write(out_gw_fp,121) (gw_ss_sum(i)%fpln,i=1,ncell) + write(out_gw_fp,121) (gw_ss_sum(i)%fpln,i=1,ncell) endif write(out_gw_fp,*) if (gw_solute_flag == 1) then !solute mass flux @@ -1884,7 +1884,7 @@ subroutine gwflow_simulate if(gwflag_yr.eq.1) then write(out_solbal_yr+s,105) time%yrc, & sol_grid_chng_yr,sol_grid_rech_yr,sol_grid_gwsw_yr,sol_grid_swgw_yr,sol_grid_satx_yr, & - sol_grid_soil_yr,sol_grid_advn_yr,sol_grid_disp_yr, & + sol_grid_soil_yr,sol_grid_advn_yr,sol_grid_disp_yr, & sol_grid_rcti_yr,sol_grid_rcto_yr,sol_grid_minl_yr,sol_grid_sorb_yr, & sol_grid_ppag_yr,sol_grid_ppex_yr,sol_grid_tile_yr,sol_grid_resv_yr,sol_grid_wetl_yr, & sol_grid_canl_yr,sol_grid_fpln_yr @@ -2510,12 +2510,12 @@ subroutine gwflow_simulate 100 format(10000(f12.3)) 101 format(10000(e12.3)) 102 format(i8,i8,f10.3,e16.7,e16.7,1000(e13.4)) -103 format(i8,i8,i8,i8,i8,i8,i8,50(f15.3)) -104 format(10000(f12.2)) +!*** tu Wunused-label: 103 format(i8,i8,i8,i8,i8,i8,i8,50(f15.3)) +!*** tu Wunused-label: 104 format(10000(f12.2)) 105 format(i8,50(e13.4)) -106 format(i8,i8,i8,50(f12.3)) -108 format(i8,2x,50(e12.4)) -109 format(i8,i8,1000(e12.3)) +!*** tu Wunused-label: 106 format(i8,i8,i8,50(f12.3)) +!*** tu Wunused-label: 108 format(i8,2x,50(e12.4)) +!*** tu Wunused-label: 109 format(i8,i8,1000(e12.3)) 110 format(i8,f20.1,i8,f12.3,f12.3,f12.3) 111 format(f20.1,f12.3,f12.3,i8) 112 format(f15.1,50(e13.4)) @@ -2529,9 +2529,9 @@ subroutine gwflow_simulate !121 format((e12.3)) 120 format(f12.3) 121 format(e12.3) -125 format(3x,i8,2x,i8,7x,f15.1,50(e13.4)) +125 format(3x,i8,2x,i8,7x,f15.1,50(e13.4)) return end subroutine gwflow_simulate - \ No newline at end of file + \ No newline at end of file diff --git a/src/gwflow_soil.f90 b/src/gwflow_soil.f90 index 5957deb..ed3d558 100644 --- a/src/gwflow_soil.f90 +++ b/src/gwflow_soil.f90 @@ -18,9 +18,9 @@ subroutine gwflow_soil(hru_id) !rtb gwflow integer :: cell_id = 0 ! |cell in connection with the channel real :: hru_Q = 0. !m3 |volume transferred from cell to the soil profile real :: hru_soilz = 0. !m |thickness of HRU soil profile + real :: vadose_z = 0. !m |thickness of cell vadose zone real :: poly_area = 0. !m2 |area of cell within the HRU real :: solmass(100) = 0. !g |solute mass transferred from cell - real :: vadose_z = 0. !m |thickness of cell vadose zone real :: water_depth(100) = 0. !m |depth of groundwater in each soil layer real :: water_depth_tot = 0. !m |total depth of groundwater in the soil profile real :: sol_thick = 0. !m |thickness of soil layer diff --git a/src/hcsout_output.f90 b/src/hcsout_output.f90 index 7f0bb79..e5f578a 100644 --- a/src/hcsout_output.f90 +++ b/src/hcsout_output.f90 @@ -35,29 +35,29 @@ subroutine hcsout_output ob(iob)%frac_out(iiout), (hcs1%path(ipath), ipath = 1, cs_db%num_paths) if (pco%csvout == "y") then write (2760,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (hcs1%path(ipath), ipath = 1, cs_db%num_paths) end if !! cvs paths end if !! paths if (cs_db%num_metals > 0) then !! metals write (2748,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (hcs1%hmet(imetal), imetal = 1, cs_db%num_metals) if (pco%csvout == "y") then write (2764,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (hcs1%hmet(imetal), imetal = 1, cs_db%num_metals) end if !! cvs metals end if !! metals if (cs_db%num_salts > 0) then !! salts write (2752,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (hcs1%salt(isalt), isalt = 1, cs_db%num_salts) if (pco%csvout == "y") then write (2768,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (hcs1%salt(isalt), isalt = 1, cs_db%num_salts) end if !! cvs salts end if !! salts @@ -71,44 +71,44 @@ subroutine hcsout_output if (pco%hyd%m == "y") then if (cs_db%num_pests > 0) then !! pests write (2741,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) if (pco%csvout == "y") then write (2757,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) end if !! cvs pests end if !! pests if (cs_db%num_paths > 0) then !! paths write (2745,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%path(ipath), ipath = 1, cs_db%num_paths) if (pco%csvout == "y") then write (2761,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%path(ipath), ipath = 1, cs_db%num_paths) end if !! cvs paths end if !! paths if (cs_db%num_metals > 0) then !! metals write (2749,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) if (pco%csvout == "y") then write (2765,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) end if !! cvs metals end if !! metals if (cs_db%num_salts > 0) then !! salts write (2753,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) if (pco%csvout == "y") then write (2769,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) end if !! cvs salts end if !! salts @@ -122,44 +122,44 @@ subroutine hcsout_output if (pco%hyd%y == "y") then if (cs_db%num_pests > 0) then !! pests write (2742,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) if (pco%csvout == "y") then write (2752,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) end if !! cvs pests end if !! pests if (cs_db%num_paths > 0) then !! paths write (2746,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%path(ipath), ipath = 1, cs_db%num_paths) if (pco%csvout == "y") then write (2762,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%path(ipath), ipath = 1, cs_db%num_paths) end if !! cvs paths end if !! paths if (cs_db%num_metals > 0) then !! metals write (2750,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) if (pco%csvout == "y") then write (2766,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) end if !! cvs metals end if !! metals if (cs_db%num_salts > 0) then !! salts write (2754,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) if (pco%csvout == "y") then write (2770,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) end if !! cvs salts end if !! salts @@ -173,44 +173,44 @@ subroutine hcsout_output ob(iob)%hin_a(iiout) = ob(iob)%hin_a(iiout) / time%yrs_prt if (cs_db%num_pests > 0) then !! pests write (2743,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) if (pco%csvout == "y") then write (2759,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%pest(ipest), ipest = 1, cs_db%num_pests) end if !! cvs pests end if !! pests if (cs_db%num_paths > 0) then !! paths write (2747,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%path(ipath), ipath = 1, cs_db%num_paths) if (pco%csvout == "y") then write (2763,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%path(ipath), ipath = 1, cs_db%num_paths) end if !! cvs paths end if !! paths if (cs_db%num_metals > 0) then !! metals write (2751,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) if (pco%csvout == "y") then write (2767,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals) end if !! cvs metals end if !! metals if (cs_db%num_salts > 0) then !! salts write (2755,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) if (pco%csvout == "y") then write (2771,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ, & - ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & + ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), & ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%salt(isalt), isalt = 1, cs_db%num_salts) end if !! cvs salts end if !! salts diff --git a/src/header_sd_channel.f90 b/src/header_sd_channel.f90 index 28a3cfc..3bc1562 100644 --- a/src/header_sd_channel.f90 +++ b/src/header_sd_channel.f90 @@ -23,7 +23,7 @@ subroutine header_sd_channel write (4814,'(*(G0.3,:,","))') sdch_hdr_units_sub write (9000,*) "SWAT-DEG_CHANNEL channel_sd_subday.csv" end if - end if + end if end if open (2500,file="channel_sd_day.txt",recl = 1500) diff --git a/src/header_write.f90 b/src/header_write.f90 index 12037f4..2b129d7 100644 --- a/src/header_write.f90 +++ b/src/header_write.f90 @@ -45,14 +45,14 @@ subroutine header_write !!!!!! hru-lte-out.cal - hru lte soft calibration output including soft and predicted budgets and !!!!!! calibration parameter adjustments !open (5003,file="hru-lte-out.cal", recl = 800) - !write (9000,*) "LTE SOFT OUT CALIB hru-lte-out.cal" - !write (5003,*) calb_hdr - + !write (9000,*) "LTE SOFT OUT CALIB hru-lte-out.cal" + !write (5003,*) calb_hdr + !!!!!! hru-lte-new.cal - hru lte soft calibration output file. The same format as hru-lte.hru and !!!!!! can be used as input (hru-lte.hru) in subsequent simulations !open (5002,file="hru-lte-new.cal", recl = 800) - !write (9000,*) "LTE SOFT CAL INPUT hru-lte-new.cal" - !write (5002,*) calb2_hdr + !write (9000,*) "LTE SOFT CAL INPUT hru-lte-new.cal" + !write (5002,*) calb2_hdr !! BASIN AQUIFER OUTPUT if (pco%aqu_bsn%d == "y") then diff --git a/src/hru_carbon_output.f90 b/src/hru_carbon_output.f90 index 30a726a..bb59160 100644 --- a/src/hru_carbon_output.f90 +++ b/src/hru_carbon_output.f90 @@ -126,12 +126,12 @@ subroutine hru_carbon_output (ihru) return -100 format (4i6,2i8,2x,a,40f12.3) -101 format (4i6,2i8,2x,a,24f12.3) -102 format (4i6,2i8,2x,a,24f12.3) -103 format (4i6,i8,4x,a,5x,4f12.3) -104 format (4i6,2i8,2x,a8,4f12.3,23f17.3) -105 format (4i6,2i8,2x,a8,8f17.3) -106 format (4i6,2i8,2x,a8,29f17.3) +!*** tu Wunused-label: 100 format (4i6,2i8,2x,a,40f12.3) +!*** tu Wunused-label: 101 format (4i6,2i8,2x,a,24f12.3) +!*** tu Wunused-label: 102 format (4i6,2i8,2x,a,24f12.3) +!*** tu Wunused-label: 103 format (4i6,i8,4x,a,5x,4f12.3) +!*** tu Wunused-label: 104 format (4i6,2i8,2x,a8,4f12.3,23f17.3) +!*** tu Wunused-label: 105 format (4i6,2i8,2x,a8,8f17.3) +!*** tu Wunused-label: 106 format (4i6,2i8,2x,a8,29f17.3) end subroutine hru_carbon_output \ No newline at end of file diff --git a/src/hru_control.f90 b/src/hru_control.f90 index 5e48e35..fd8d856 100644 --- a/src/hru_control.f90 +++ b/src/hru_control.f90 @@ -12,7 +12,7 @@ subroutine hru_control snofall, snomlt, usle, canev, ep_day, es_day, etday, inflpcp, isep, iwgen, ls_overq, & nd_30, pet_day, precip_eff, qday, latqrunon, gwsoilq, satexq, surf_bs, bss, bss_ex, brt, & gwsoiln, gwsoilp, satexn, satexq_chan, surqsalt, latqsalt, tilesalt, percsalt, urbqsalt, & !rtb gwflow; rtb salt - wetqsalt, wtspsalt,gwupsalt, & + wetqsalt, wtspsalt,gwupsalt, usle_cfac, & surqcs, latqcs, tilecs, perccs, gwupcs, sedmcs, urbqcs, wetqcs, wtspcs !rtb cs !HAK 7/27/22 use soil_module @@ -77,6 +77,9 @@ subroutine hru_control real :: sum_conc = 0. !rtb salt real :: sum_mass = 0. !rtb salt real :: sum_sorb = 0. !rtb salt + real :: saltcon = 0. !Jeong 2024 + real :: qsurf = 0. !Jeong 2024 + real :: sedppm = 0. !Jeong 2024 j = ihru @@ -254,9 +257,9 @@ subroutine hru_control end if !!add tile flow to tile (subirrigation and saturated buffer) - if (ob(icmd)%hin_til%flo > 1.e-6 .and. tile_fr_surf > 1.e-6) then - call rls_routetile (icmd, tile_fr_surf) - end if + !if (ob(icmd)%hin_til%flo > 1.e-6 .and. tile_fr_surf > 1.e-6) then + ! call rls_routetile (icmd, tile_fr_surf) + !end if !!add aquifer flow to bottom soil layer and redistribute upwards if (ob(icmd)%hin_aqu%flo > 0) then @@ -348,18 +351,21 @@ subroutine hru_control end if end if + !! compute residue decomposition + call rsd_decomp + !! compute nitrogen and phosphorus mineralization if (bsn_cc%cswat == 0) then call nut_nminrl end if - if (bsn_cc%cswat == 2) then - call cbn_zhang2 - end if + if (bsn_cc%cswat == 2) then + call cbn_zhang2 + end if call nut_nitvol - if (bsn_cc%sol_P_model == 1) then + if (bsn_cc%sol_P_model == 1) then call nut_pminrl2 else call nut_pminrl @@ -368,12 +374,19 @@ subroutine hru_control !! compute biozone processes in septic HRUs !! if 1) current is septic hru and 2) soil temperature is above zero isep = iseptic(j) - if (sep(isep)%opt /= 0. .and. time%yrc >= sep(isep)%yr) then - if (soil(j)%phys(i_sep(j))%tmp > 0.) call sep_biozone + if (sep(isep)%opt /= 0. .and. time%yrc >= sep(isep)%yr) then + if (soil(j)%phys(i_sep(j))%tmp > 0.) call sep_biozone endif !! compute plant community partitions call pl_community + !if (j == 136) then + !write (7778,*) time%day, j, pl_mass(j)%tot(1)%m, pl_mass(j)%ab_gr(1)%m, pl_mass(j)%stem(1)%m, & + ! pl_mass(j)%leaf(1)%m, pl_mass(j)%root(1)%m, pl_mass(j)%seed(1)%m + !end if + !if (j == 173) then + ! write (7778,*) time%day, j, sedyld(j)/hru(j)%area_ha, usle_cfac(j), surfq(j), qp_cms + !end if !! check irrigation demand decision table for water allocation (after adding irrigation) if (hru(j)%irr_dmd_dtbl > 0) then @@ -517,6 +530,20 @@ subroutine hru_control !! compute nitrate movement leaching call nut_nlch + if (ires > 0) then + if (wet(j)%flo>0) then + sedppm=wet(j)%sed/wet(j)%flo*1000000. + else + sedppm=0. + end if + if (wet_dat_c(ires)%hyd.eq.'paddy') then !.and.time%yrs > pco%nyskip) then + if (wet_ob(j)%depth > 100.) then + write(100100,'(4(I6,","),20(f20.1,","))') time%yrc,time%mo,time%day_mo,j,w%precip,irrig(j)%applied,hru(j)%water_seep, & + pet_day,etday,wet_ob(j)%weir_hgt*1000,wet_ob(j)%depth*1000.,ht2%flo/(hru(j)%area_ha*10.),soil(j)%sw,sedppm,ht2%sed*1000, & + wet(j)%no3,ht2%no3,pcom(j)%lai_sum,saltcon + end if + end if + end if !! compute phosphorus movement call nut_solp @@ -547,12 +574,12 @@ subroutine hru_control !! compute loadings from urban areas if (hru(j)%luse%urb_lu > 0) then - if (time%step == 1) then + if (time%step == 1) then call hru_urban ! daily simulation - else + else call hru_urbanhr ! subdaily simulation J.Jeong 4/20/2009 - endif - endif + endif + endif !! compute sediment loading in lateral flow and add to sedyld call swr_latsed @@ -569,19 +596,20 @@ subroutine hru_control if (filterw(j) > 0.) call smp_buffer end if - !! compute reduction in pollutants due to in field grass waterway + !! compute reduction in pollutants due to in field grass waterway if (hru(j)%lumv%grwat_i == 1) then call smp_grass_wway end if - !! compute reduction in pollutants due to in fixed BMP eff - if (hru(j)%lumv%bmp_flag == 1) then + !! compute reduction in pollutants due to in fixed BMP eff + if (hru(j)%lumv%bmp_flag == 1) then call smp_bmpfixed end if !! ht2%flo is outflow from wetland or total saturation excess if no wetland if(ht2%flo > 0.) then wet_outflow = ht2%flo / hru(j)%area_ha / 10. !! mm = m3/ha *ha/10000m2 *1000mm/m + qday = qday + wet_outflow qdr(j) = qdr(j) + wet_outflow ht2%flo = 0. end if @@ -616,6 +644,7 @@ subroutine hru_control if (ob(iob)%ru_tot > 0) then iob_out = sp_ob1%ru + ob(iob)%ru(1) - 1 end if + qsurf=surfq(j) hwb_d(j)%surq_cha = 0. hwb_d(j)%latq_cha = 0. diff --git a/src/hru_cs_output.f90 b/src/hru_cs_output.f90 index 7de4ed7..5b1c3af 100644 --- a/src/hru_cs_output.f90 +++ b/src/hru_cs_output.f90 @@ -69,7 +69,7 @@ subroutine hru_cs_output(ihru) !rtb cs (hcsb_d(j)%cs(ics)%srbd,ics=1,cs_db%num_cs) if (pco%csvout == "y") then write (6022,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, & - (hcsb_d(j)%cs(ics)%soil,ics=1,cs_db%num_cs), & + (hcsb_d(j)%cs(ics)%soil,ics=1,cs_db%num_cs), & (hcsb_d(j)%cs(ics)%surq,ics=1,cs_db%num_cs), & (hcsb_d(j)%cs(ics)%sedm,ics=1,cs_db%num_cs), & (hcsb_d(j)%cs(ics)%latq,ics=1,cs_db%num_cs), & diff --git a/src/hru_hyds.f90 b/src/hru_hyds.f90 index b1d1138..8c9cf74 100644 --- a/src/hru_hyds.f90 +++ b/src/hru_hyds.f90 @@ -93,10 +93,10 @@ subroutine hru_hyds obcs(icmd)%hd(3)%path(ipath) = 0 end do do isalt = 1, cs_db%num_salts !rtb salt - obcs(icmd)%hd(3)%salt(isalt) = (surqsalt(j,isalt)+urbqsalt(j,isalt)+wetqsalt(j,isalt)) * cnv_kg !kg of each salt ion + obcs(icmd)%hd(3)%salt(isalt) = (surqsalt(j,isalt)+urbqsalt(j,isalt)+wetqsalt(j,isalt)) * cnv_kg !kg of each salt ion enddo do ics = 1, cs_db%num_cs !rtb cs - obcs(icmd)%hd(3)%cs(ics) = (surqcs(j,ics)+sedmcs(j,ics)+urbqcs(j,ics)+wetqcs(j,ics)) * cnv_kg !kg of each constituent (surface runoff + attached) + obcs(icmd)%hd(3)%cs(ics) = (surqcs(j,ics)+sedmcs(j,ics)+urbqcs(j,ics)+wetqcs(j,ics)) * cnv_kg !kg of each constituent (surface runoff + attached) enddo !recharge hydrograph (2) diff --git a/src/hru_lte_control.f90 b/src/hru_lte_control.f90 index e6a9989..f773e51 100644 --- a/src/hru_lte_control.f90 +++ b/src/hru_lte_control.f90 @@ -347,19 +347,19 @@ subroutine hru_lte_control (isd) !! compute channel peak rate using SCS triangular unit hydrograph chflow_m3 = 1000. * chflow * ob(icmd)%area_ha - runoff_m3 = 1000. * runoff * ob(icmd)%area_ha - bf_m3 = 1000. * (flowlat + hlt(isd)%gwflow)*ob(icmd)%area_ha + runoff_m3 = 1000. * runoff * ob(icmd)%area_ha + bf_m3 = 1000. * (flowlat + hlt(isd)%gwflow)*ob(icmd)%area_ha peakr = 2. * runoff_m3 / (1.5 * hlt_db(ihlt_db)%tc) - peakrbf = bf_m3 / 86400. + peakrbf = bf_m3 / 86400. peakr = (peakr + peakrbf) !* prf !! compute sediment yield with MUSLE sedin = (runoff * peakr * 1000. * ob(icmd)%area_ha) ** .56 * hlt(isd)%uslefac - !! add subsurf sediment - t=ppm*mm*km2/1000. - qssubconc = 500. - qssub = qssubconc * (flowlat + hlt(isd)%gwflow) * ob(icmd)%area_ha / 1000. - sedin = sedin + qssub + !! add subsurf sediment - t=ppm*mm*km2/1000. + qssubconc = 500. + qssub = qssubconc * (flowlat + hlt(isd)%gwflow) * ob(icmd)%area_ha / 1000. + sedin = sedin + qssub cnv = ob(icmd)%area_ha * 1000. diff --git a/src/hru_module.f90 b/src/hru_module.f90 index 73b16bb..4adf6e6 100644 --- a/src/hru_module.f90 +++ b/src/hru_module.f90 @@ -28,7 +28,7 @@ module hru_module type topography character(len=40) :: name = "" real :: elev = 0. !! |m |elevation of HRU - real :: slope = 0. !! hru_slp(:) |m/m |average slope steepness in HRU + real :: slope = 0. !! hru_slp(:) |m/m |average slope steepness in HRU real :: slope_len = 0. !! slsubbsn(:) |m |average slope length for erosion real :: dr_den = 0. !! |km/km2 |drainage density real :: lat_len = 0. !! slsoil(:) |m |slope length for lateral subsurface flow @@ -100,7 +100,7 @@ module hru_module integer :: cn_lu = 0 integer :: cons_prac = 0 real :: usle_p = 0. !! none | USLE equation support practice (P) factor daily - character (len=16) :: urb_ro = ""!! none | urban runoff model + character (len=40) :: urb_ro = ""!! none | urban runoff model !! | "usgs_reg", simulate using USGS regression eqs !! | "buildup_washoff", simulate using build up/wash off alg integer :: urb_lu = 0 !! none | urban land type identification number @@ -184,7 +184,7 @@ module hru_module integer :: vfsi = 0 !! |none |on/off flag for vegetative filter strip real :: vfsratio = 0. !! |none |contouring USLE P factor real :: vfscon = 0. !! |none |fraction of the total runoff from the entire field - real :: vfsch = 0; !! |none |fraction of flow entering the most concentrated 10% of the VFS. + real :: vfsch = 0. !! |none |fraction of flow entering the most concentrated 10% of the VFS. !! which is fully channelized integer :: ngrwat = 0 integer :: grwat_i = 0 !! |none |On/off Flag for waterway simulation @@ -215,7 +215,7 @@ module hru_module character(len=40) :: land_use_mgt_c = "" integer :: lum_group = 0 character(len=40) :: lum_group_c = "" !land use group for soft cal and output - character(len=40) :: region = "" + character(len=40) :: cal_group = "" integer :: plant_cov = 0 integer :: mgt_ops = 0 integer :: tiledrain = 0 @@ -251,7 +251,7 @@ module hru_module real :: wet_obank_in = 0. !mm |inflow from overbank into wetlands real :: precip_aa = 0. character(len=1) :: wet_fp = "n" - character(len=5) :: irr_src = "unlim" ! |irrigation source, Jaehak 2022 + character(len=40) :: irr_src = "unlim" ! |irrigation source, Jaehak 2022 real :: strsa = 0. real :: irr_hmax = 0 !mm H2O |target ponding depth during paddy irrigation Jaehak 2022 real :: irr_hmin = 0 !mm H2O |threshold ponding depth to trigger paddy irrigation @@ -489,15 +489,15 @@ module hru_module ! Modifications to Pesticide and Water routing routines by Balaji Narasimhan !Additional buffer and filter strip variables Mike White - real, dimension (:), allocatable :: ubnrunoff - real, dimension (:), allocatable :: ubntss - real, dimension (:,:), allocatable :: ovrlnd_dt - real, dimension (:,:), allocatable :: hhsurfq - real, dimension (:,:,:), allocatable :: hhsurf_bs + real, dimension (:), allocatable :: ubnrunoff + real, dimension (:), allocatable :: ubntss + real, dimension (:,:), allocatable :: ovrlnd_dt + real, dimension (:,:), allocatable :: hhsurfq + real, dimension (:,:,:), allocatable :: hhsurf_bs !! subdaily erosion modeling by Jaehak Jeong - real, dimension(:,:), allocatable:: hhsedy - real, dimension(:), allocatable:: init_abstrc + real, dimension(:,:), allocatable:: hhsedy + real, dimension(:), allocatable:: init_abstrc integer, dimension(:), allocatable :: tillage_switch real, dimension(:), allocatable :: tillage_depth diff --git a/src/hru_output.f90 b/src/hru_output.f90 index 74239c5..8d9f138 100644 --- a/src/hru_output.f90 +++ b/src/hru_output.f90 @@ -10,6 +10,7 @@ subroutine hru_output (ihru) use soil_module use carbon_module use hru_module, only : hru + use landuse_data_module implicit none @@ -18,6 +19,7 @@ subroutine hru_output (ihru) integer :: j = 0 integer :: iob = 0 integer :: ipl = 0 + integer :: ilu = 0 real :: const = 0. real :: sw_init = 0. real :: sno_init = 0. @@ -28,6 +30,7 @@ subroutine hru_output (ihru) j = ihru iob = sp_ob1%hru + j - 1 !!!!!! added for new output write + ilu = hru(j)%land_use_mgt hwb_m(j) = hwb_m(j) + hwb_d(j) hnb_m(j) = hnb_m(j) + hnb_d(j) @@ -42,31 +45,39 @@ subroutine hru_output (ihru) !! daily print if (pco%day_print == "y" .and. pco%int_day_cur == pco%int_day) then if (pco%wb_hru%d == "y") then - write (2000,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_d(j) !! waterbal + write (2000,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_d(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! water bal day if (pco%csvout == "y") then !! changed write unit below (2004 to write file data) - write (2004,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_d(j) !! waterbal + write (2004,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hwb_d(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if hwb_d(j)%sw_init = hwb_d(j)%sw_final hwb_d(j)%sno_init = hwb_d(j)%sno_final if (pco%nb_hru%d == "y") then - write (2020,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_d(j) !! nutrient bal + write (2020,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_d(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! nutrient bal day if (pco%csvout == "y") then - write (2024,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_d(j) !! nutrient bal + write (2024,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hnb_d(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%ls_hru%d == "y") then - write (2030,102) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_d(j) !! losses + write (2030,108) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_d(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! losses day if (pco%csvout == "y") then - write (2034,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_d(j) !! losses + write (2034,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hls_d(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%pw_hru%d == "y") then - write (2040,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_d(j) !! plant weather + write (2040,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_d(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! plant weather day if (pco%csvout == "y") then - write (2044,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_d(j) !! plant weather + write (2044,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hpw_d(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if end if @@ -87,32 +98,40 @@ subroutine hru_output (ihru) hwb_m(j)%sno_final = hwb_d(j)%sno_final if (pco%wb_hru%m == "y") then - write (2001,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_m(j) + write (2001,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_m(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! water bal mon if (pco%csvout == "y") then - write (2005,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_m(j) + write (2005,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hwb_m(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%nb_hru%m == "y") then - write (2021,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_m(j) + write (2021,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_m(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! nutrient bal mon if (pco%csvout == "y") then - write (2025,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_m(j) + write (2025,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hnb_m(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%ls_hru%m == "y") then - write (2031,102) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_m(j) + write (2031,108) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_m(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! losses mon if (pco%csvout == "y") then - write (2035,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_m(j) + write (2035,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hls_m(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%pw_hru%m == "y") then hpw_m(j)%nplnt = pl_mass(j)%tot_com%n hpw_m(j)%pplnt = pl_mass(j)%tot_com%p - write (2041,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_m(j) + write (2041,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_m(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! plant weather mon if (pco%csvout == "y") then - write (2045,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_m(j) + write (2045,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hpw_m(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if @@ -145,32 +164,40 @@ subroutine hru_output (ihru) hru(j)%irr = 1 end if if (pco%wb_hru%y == "y") then - write (2002,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_y(j) + write (2002,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_y(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! water balance yr if (pco%csvout == "y") then - write (2006,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_y(j) + write (2006,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hwb_y(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%nb_hru%y == "y") then - write (2022,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_y(j) + write (2022,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_y(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! nutrient balance yr if (pco%csvout == "y") then - write (2026,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_y(j) + write (2026,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hnb_y(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%ls_hru%y == "y") then - write (2032,102) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_y(j) + write (2032,108) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_y(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! losses yr if (pco%csvout == "y") then - write (2036,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_y(j) + write (2036,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hls_y(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if if (pco%pw_hru%y == "y") then hpw_y(j)%nplnt = pl_mass(j)%tot_com%n hpw_y(j)%pplnt = pl_mass(j)%tot_com%p - write (2042,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_y(j) + write (2042,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_y(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! plant weather yr if (pco%csvout == "y") then - write (2046,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_y(j) + write (2046,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hpw_y(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if @@ -188,9 +215,11 @@ subroutine hru_output (ihru) hwb_a(j)%sno_init = sno_init hwb_a(j)%sno_final = hwb_d(j)%sno_final if (pco%wb_hru%a == "y") then - write (2003,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_a(j) + write (2003,100) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_a(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! water balance ann if (pco%csvout == "y") then - write (2007,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hwb_a(j) + write (2007,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hwb_a(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if end if sw_init = hwb_d(j)%sw_final @@ -208,18 +237,22 @@ subroutine hru_output (ihru) if (time%end_sim == 1 .and. pco%nb_hru%a == "y") then hnb_a(j) = hnb_a(j) / time%yrs_prt - write (2023,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_a(j) + write (2023,104) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_a(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! nutrient bal ann if (pco%csvout == "y") then - write (2027,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hnb_a(j) + write (2027,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hnb_a(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if hnb_a(j) = hnbz end if if (time%end_sim == 1 .and. pco%ls_hru%a == "y") then hls_a(j) = hls_a(j) / time%yrs_prt - write (2033,101) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_a(j) + write (2033,107) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_a(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! losses ann if (pco%csvout == "y") then - write (2037,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hls_a(j) + write (2037,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hls_a(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if hls_a(j) = hlsz end if @@ -229,9 +262,11 @@ subroutine hru_output (ihru) hpw_a(j) = hpw_a(j) // time%days_prt hpw_a(j)%nplnt = pl_mass(j)%tot_com%n hpw_a(j)%pplnt = pl_mass(j)%tot_com%p - write (2043,102) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_a(j) + write (2043,102) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_a(j), & + lum(ilu)%plant_cov, lum(ilu)%mgt_ops !! plant weather ann if (pco%csvout == "y") then - write (2047,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, hpw_a(j) + write (2047,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & + hpw_a(j), lum(ilu)%plant_cov, lum(ilu)%mgt_ops end if hru(j)%strsa = hpw_a(j)%strsa hpw_a(j) = hpwz @@ -240,43 +275,41 @@ subroutine hru_output (ihru) !! write yearly crop yields if (time%end_yr == 1) then if (pco%crop_yld == "y" .or. pco%crop_yld == "b") then - do ipl = 1, pcom(j)%npl - if (pcom(j)%plcur(ipl)%harv_num_yr > 0) then - pl_mass(j)%yield_yr(ipl) = pl_mass(j)%yield_yr(ipl) / float(pcom(j)%plcur(ipl)%harv_num_yr) - endif - if (pco%crop_yld == "y" .or. pco%crop_yld == "b") then - write (4010,103) time%day, time%mo, time%day_mo, time%yrc, j, pcom(j)%pl(ipl), pl_mass(j)%yield_yr(ipl) - end if - if (pco%csvout == "y") then - write (4011,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, pcom(j)%pl(ipl), pl_mass(j)%yield_yr(ipl) - end if - end do + do ipl = 1, pcom(j)%npl + if (pcom(j)%plcur(ipl)%harv_num_yr > 0) then + pl_mass(j)%yield_yr(ipl) = pl_mass(j)%yield_yr(ipl) / float(pcom(j)%plcur(ipl)%harv_num_yr) + endif + write (4010,103) time%day, time%mo, time%day_mo, time%yrc, j, pcom(j)%pl(ipl), pl_mass(j)%yield_yr(ipl) + if (pco%csvout == "y") then + write (4011,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, pcom(j)%pl(ipl), pl_mass(j)%yield_yr(ipl) + end if + end do end if end if !! write average annual crop yields if (time%end_sim == 1) then if (pco%crop_yld == "a" .or. pco%crop_yld == "b") then - do ipl = 1, pcom(j)%npl - idp = pcom(j)%plcur(ipl)%idplt - if (pcom(j)%plcur(ipl)%harv_num > 0) then - pl_mass(j)%yield_tot(ipl) = pl_mass(j)%yield_tot(ipl) / float(pcom(j)%plcur(ipl)%harv_num) - endif - write (4008,103) time%day, time%mo, time%day_mo, time%yrc, j,pldb(idp)%plantnm, pl_mass(j)%yield_tot(ipl) - if (pco%csvout == "y") then - write (4009,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j,pldb(idp)%plantnm, pl_mass(j)%yield_tot(ipl) - end if - end do + do ipl = 1, pcom(j)%npl + idp = pcom(j)%plcur(ipl)%idplt + if (pcom(j)%plcur(ipl)%harv_num > 0) then + pl_mass(j)%yield_tot(ipl) = pl_mass(j)%yield_tot(ipl) / float(pcom(j)%plcur(ipl)%harv_num) + endif + write (4008,103) time%day, time%mo, time%day_mo, time%yrc, j,pldb(idp)%plantnm, pl_mass(j)%yield_tot(ipl) + if (pco%csvout == "y") then + write (4009,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j,pldb(idp)%plantnm, pl_mass(j)%yield_tot(ipl) + end if + end do end if end if return -100 format (4i6,2i8,2x,a,42f12.3) -101 format (4i6,2i8,2x,a,25f12.3) !!!!!!!!!! nbs chg -102 format (4i6,2i8,2x,a,25f12.3) !!!!!!!!!! nbs chg +100 format (4i6,2i8,2x,a,42f12.3,3x,a16,a30) +101 format (4i6,2i8,2x,a,25f12.3,3x,a16,a30) +102 format (4i6,2i8,2x,a,25f12.3,3x,a16,a30) 103 format (4i6,i8,4x,a,5x,4f12.3) -104 format (4i6,2i8,2x,a8,4f12.3,23f17.3) -105 format (4i6,2i8,2x,a8,8f17.3) -106 format (4i6,2i8,2x,a8,29f17.3) +104 format (4i6,2i8,2x,a8,4f12.3,15f17.3,7x,a16,a30) +107 format (4i6,2i8,2x,a,12f12.3,3x,a16,a30) +108 format (4i6,2i8,2x,a,12f12.3,3x,a16,a30) end subroutine hru_output \ No newline at end of file diff --git a/src/hru_pathogen_output.f90 b/src/hru_pathogen_output.f90 index 4a50735..abbee3b 100644 --- a/src/hru_pathogen_output.f90 +++ b/src/hru_pathogen_output.f90 @@ -98,8 +98,8 @@ subroutine hru_pathogen_output(ihru) return 100 format (4i6,2i8,2x,a,11e12.3) -101 format (4i6,2i8,2x,a,11e12.3) -102 format (4i6,2i8,2x,a,11e12.3) -103 format (2i6,i8,4x,a,5x,11e12.3) +!*** tu Wunused-label: 101 format (4i6,2i8,2x,a,11e12.3) +!*** tu Wunused-label: 102 format (4i6,2i8,2x,a,11e12.3) +!*** tu Wunused-label: 103 format (2i6,i8,4x,a,5x,11e12.3) end subroutine hru_pathogen_output \ No newline at end of file diff --git a/src/hru_read.f90 b/src/hru_read.f90 index e59f809..97d13b7 100644 --- a/src/hru_read.f90 +++ b/src/hru_read.f90 @@ -59,7 +59,7 @@ subroutine hru_read read (113,*,iostat=eof) header if (eof < 0) exit - do ihru = 1, sp_ob%hru + do ihru = 1, imax read (113,*,iostat=eof) i if (eof < 0) exit backspace (113) diff --git a/src/hru_salt_output.f90 b/src/hru_salt_output.f90 index 5034569..c3f6128 100644 --- a/src/hru_salt_output.f90 +++ b/src/hru_salt_output.f90 @@ -67,7 +67,7 @@ subroutine hru_salt_output(ihru) hsaltb_d(j)%salt(1)%diss if (pco%csvout == "y") then write (5022,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, & - (hsaltb_d(j)%salt(isalt)%soil,isalt=1,cs_db%num_salts), & + (hsaltb_d(j)%salt(isalt)%soil,isalt=1,cs_db%num_salts), & (hsaltb_d(j)%salt(isalt)%surq,isalt=1,cs_db%num_salts), & (hsaltb_d(j)%salt(isalt)%latq,isalt=1,cs_db%num_salts), & (hsaltb_d(j)%salt(isalt)%urbq,isalt=1,cs_db%num_salts), & diff --git a/src/hru_urb_bmp.f90 b/src/hru_urb_bmp.f90 index 25c63a3..5606b72 100644 --- a/src/hru_urb_bmp.f90 +++ b/src/hru_urb_bmp.f90 @@ -14,12 +14,12 @@ subroutine hru_urb_bmp real :: sednppm = 0. ! | real :: sedpppm = 0. ! | - j = 0 - j = ihru + j = 0 + j = ihru !! convert to ppm -> (kg/ha)*100./mm = ppm if (qdr(j) > 0.1) then - xx = 100. / qdr(j) + xx = 100. / qdr(j) sedppm = 1000. * xx * sedyld(j) / hru(j)%area_ha solnppm = xx * (surqno3(j) + latno3(j)) solpppm = xx * surqsolp(j) @@ -31,7 +31,7 @@ subroutine hru_urb_bmp endif if (solnppm > soln_con(j)) then - surqno3(j) = soln_con(j) / xx + surqno3(j) = soln_con(j) / xx latno3(j) = soln_con(j) / xx endif @@ -44,12 +44,12 @@ subroutine hru_urb_bmp endif if (sedpppm > orgp_con(j)) then - sedorgn(j)= orgp_con(j) / xx + sedorgn(j)= orgp_con(j) / xx sedminpa(j)= orgp_con(j) / xx - sedminps(j)= orgp_con(j) / xx + sedminps(j)= orgp_con(j) / xx endif - endif + endif return end subroutine hru_urb_bmp \ No newline at end of file diff --git a/src/hru_urbanhr.f90 b/src/hru_urbanhr.f90 index 042121b..a8924f2 100644 --- a/src/hru_urbanhr.f90 +++ b/src/hru_urbanhr.f90 @@ -68,7 +68,7 @@ subroutine hru_urbanhr ! |surfaces at the beginning of time step integer :: j = 0 !none |HRU number real :: qdt = 0. ! | - real*8 :: dirt = 0.d0 !kg/curb km |amount of solids built up on impervious + real*8 :: dirt = 0.d0 !kg/curb km |amount of solids built up on impervious ! |surfaces integer :: k = 0 !none |counter integer :: tno3 = 0 ! | @@ -76,14 +76,14 @@ subroutine hru_urbanhr j = ihru ulu = hru(j)%luse%urb_lu - do k = 1, time%step + do k = 1, time%step !! build-up/wash-off algorithm !! rainy day: no build-up, street cleaning allowed - - qdt = ubnrunoff(k) * 60./ real(time%dtm) !urban runoff in mm/hr - if (qdt > 0.025 .and. surfq(j) > 0.1) then ! SWMM : 0.001 in/hr (=0.0254mm/hr) + + qdt = ubnrunoff(k) * 60./ real(time%dtm) !urban runoff in mm/hr + if (qdt > 0.025 .and. surfq(j) > 0.1) then ! SWMM : 0.001 in/hr (=0.0254mm/hr) !! calculate amount of dirt on streets prior to wash-off dirt = 0. @@ -91,7 +91,7 @@ subroutine hru_urbanhr dirto = urbdb(ulu)%dirtmx * twash(j) / (urbdb(ulu)%thalf + twash(j)) !! calculate wash-off of solids - urbk = 0. ! qp_cms -> hhqday for subdaily time steps 6/19/09 JJ + urbk = 0. ! qp_cms -> hhqday for subdaily time steps 6/19/09 JJ urbk = urbdb(ulu)%urbcoef * qdt dirt=dirto * Exp (- urbk * real(time%dtm) / 60.) @@ -119,7 +119,7 @@ subroutine hru_urbanhr (1. - urbdb(ulu)%fimp) surqsolp(j) = .25 * tp * urbdb(ulu)%fimp + surqsolp(j) * & (1. - urbdb(ulu)%fimp) - else + else !! no surface runoff twash(j) = twash(j) + time%dtm / 1440. @@ -135,26 +135,26 @@ subroutine hru_urbanhr end if end if - sus_sol=0 - - ! Compute evaporation of water (initial abstraction) from impervious cover - init_abstrc(j) = init_abstrc(j) - etday / time%step - init_abstrc(j) = max(0.,init_abstrc(j)) - end do + sus_sol=0 + + ! Compute evaporation of water (initial abstraction) from impervious cover + init_abstrc(j) = init_abstrc(j) - etday / time%step + init_abstrc(j) = max(0.,init_abstrc(j)) + end do !! perform street sweeping if(surfq(j) < 0.1) then - if (isweep(j) > 0 .and. time%day >= isweep(j)) then + if (isweep(j) > 0 .and. time%day >= isweep(j)) then call hru_sweep else if (phusw(j) > 0.0001) then if (pcom(j)%plcur(ipl)%gro == "n") then if (phubase(j) > phusw(j)) then - call hru_sweep - endif + call hru_sweep + endif else if (pcom(j)%plcur(1)%phuacc > phusw(j)) then - call hru_sweep - endif + call hru_sweep + endif end if end if end if diff --git a/src/hrudb_init.f90 b/src/hrudb_init.f90 index abdce2f..e70a5b4 100644 --- a/src/hrudb_init.f90 +++ b/src/hrudb_init.f90 @@ -2,6 +2,7 @@ subroutine hrudb_init use hydrograph_module, only : sp_ob, sp_ob1, ob use hru_module, only : hru, hru_db + use landuse_data_module implicit none @@ -9,6 +10,8 @@ subroutine hrudb_init integer :: ihru = 0 !none |counter integer :: iob = 0 ! | integer :: ihru_db = 0 ! | + integer :: ilu = 0 ! | + !!assign database pointers for the hru imp = 0 @@ -21,6 +24,8 @@ subroutine hrudb_init hru(ihru)%area_ha = ob(iob)%area_ha hru(ihru)%km = ob(iob)%area_ha / 100. hru(ihru)%land_use_mgt_c = hru_db(ihru_db)%dbsc%land_use_mgt + ilu = hru(ihru)%dbs%land_use_mgt + hru(ihru)%cal_group = lum(ilu)%cal_group end do return diff --git a/src/hyd_connect.f90 b/src/hyd_connect.f90 index 834af9e..793f0fd 100644 --- a/src/hyd_connect.f90 +++ b/src/hyd_connect.f90 @@ -298,36 +298,28 @@ subroutine hyd_connect !! allocate zero arrays for constituents allocate (hin_csz%pest(cs_db%num_pests), source = 0.) allocate (hin_csz%path(cs_db%num_paths), source = 0.) + allocate (hin_csz%hmet(cs_db%num_metals), source = 0.) allocate (hin_csz%salt(cs_db%num_salts), source = 0.) !rtb salt - allocate (hin_csz%cs(cs_db%num_cs), source = 0.) !rtb se - + allocate (hcs1%pest(cs_db%num_pests), source = 0.) allocate (hcs1%path(cs_db%num_paths), source = 0.) + allocate (hcs1%hmet(cs_db%num_metals), source = 0.) allocate (hcs1%salt(cs_db%num_salts), source = 0.) !rtb salt - allocate (hcs1%cs(cs_db%num_cs), source = 0.) !rtb cs - + allocate (hcs2%pest(cs_db%num_pests), source = 0.) allocate (hcs2%path(cs_db%num_paths), source = 0.) + allocate (hcs2%hmet(cs_db%num_metals), source = 0.) allocate (hcs2%salt(cs_db%num_salts), source = 0.) !rtb salt - allocate (hcs2%cs(cs_db%num_cs), source = 0.) !rtb cs - + allocate (hcs3%pest(cs_db%num_pests), source = 0.) allocate (hcs3%path(cs_db%num_paths), source = 0.) + allocate (hcs3%hmet(cs_db%num_metals), source = 0.) allocate (hcs3%salt(cs_db%num_salts), source = 0.) !rtb salt - allocate (hcs3%cs(cs_db%num_cs), source = 0.) !rtb cs - - allocate (hcs1%hmet(cs_db%num_metals), source = 0.) - - allocate (hcs2%hmet(cs_db%num_metals), source = 0.) - - allocate (hcs3%hmet(cs_db%num_metals), source = 0.) - allocate (hin_csz%hmet(cs_db%num_metals), source = 0.) - hin_csz%pest = 0. hin_csz%path = 0. hin_csz%hmet = 0. diff --git a/src/hyd_read_connect.f90 b/src/hyd_read_connect.f90 index c97884a..8e81a69 100644 --- a/src/hyd_read_connect.f90 +++ b/src/hyd_read_connect.f90 @@ -73,7 +73,7 @@ subroutine hyd_read_connect(con_file, obtyp, nspu1, nspu, nhyds, ndsave) ob(i)%trans = hz ob(i)%hin_tot = hz ob(i)%hout_tot = hz - + ob(i)%hd_aa(:) = hz if (cs_db%num_tot > 0) then @@ -96,13 +96,14 @@ subroutine hyd_read_connect(con_file, obtyp, nspu1, nspu, nhyds, ndsave) allocate (obcs(i)%hin_sur(1)%pest(npests), source = 0.) allocate (obcs(i)%hin_lat(1)%pest(npests), source = 0.) allocate (obcs(i)%hin_til(1)%pest(npests), source = 0.) - allocate (obcs(i)%hin(1)%path(npaths), source = 0.) - allocate (obcs(i)%hin_sur(1)%path(npaths), source = 0.) - allocate (obcs(i)%hin_lat(1)%path(npaths), source = 0.) - allocate (obcs(i)%hin_til(1)%path(npaths), source = 0.) + end if npaths = cs_db%num_paths if (npaths > 0) then + allocate (obcs(i)%hin(1)%path(npaths), source = 0.) + allocate (obcs(i)%hin_sur(1)%path(npaths), source = 0.) + allocate (obcs(i)%hin_lat(1)%path(npaths), source = 0.) + allocate (obcs(i)%hin_til(1)%path(npaths), source = 0.) end if nmetals = cs_db%num_metals if (nmetals > 0) then @@ -141,18 +142,18 @@ subroutine hyd_read_connect(con_file, obtyp, nspu1, nspu, nhyds, ndsave) ncs = cs_db%num_cs !rtb cs if (ncs > 0) then allocate (obcs(i)%hin(1)%cs(ncs), source = 0.) - allocate (obcs(i)%hin_sur(1)%cs(ncs), source = 0.) - allocate (obcs(i)%hin_lat(1)%cs(ncs), source = 0.) - allocate (obcs(i)%hin_til(1)%cs(ncs), source = 0.) allocate (obcs(i)%hin(1)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hin(1)%csc(ncs), source = 0.) allocate (obcs(i)%hin(1)%csc_sorb(ncs), source = 0.) + allocate (obcs(i)%hin_sur(1)%cs(ncs), source = 0.) allocate (obcs(i)%hin_sur(1)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hin_sur(1)%csc(ncs), source = 0.) allocate (obcs(i)%hin_sur(1)%csc_sorb(ncs), source = 0.) + allocate (obcs(i)%hin_lat(1)%cs(ncs), source = 0.) allocate (obcs(i)%hin_lat(1)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hin_lat(1)%csc(ncs), source = 0.) allocate (obcs(i)%hin_lat(1)%csc_sorb(ncs), source = 0.) + allocate (obcs(i)%hin_til(1)%cs(ncs), source = 0.) allocate (obcs(i)%hin_til(1)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hin_til(1)%csc(ncs), source = 0.) allocate (obcs(i)%hin_til(1)%csc_sorb(ncs), source = 0.) @@ -249,12 +250,13 @@ subroutine hyd_read_connect(con_file, obtyp, nspu1, nspu, nhyds, ndsave) allocate (obcs(i)%hcsout_m(iout)%pest(npests), source = 0.) allocate (obcs(i)%hcsout_y(iout)%pest(npests), source = 0.) allocate (obcs(i)%hcsout_a(iout)%pest(npests), source = 0.) - allocate (obcs(i)%hcsout_m(iout)%path(npaths), source = 0.) - allocate (obcs(i)%hcsout_y(iout)%path(npaths), source = 0.) - allocate (obcs(i)%hcsout_a(iout)%path(npaths), source = 0.) + end if npaths = cs_db%num_paths if (npaths > 0) then + allocate (obcs(i)%hcsout_m(iout)%path(npaths), source = 0.) + allocate (obcs(i)%hcsout_y(iout)%path(npaths), source = 0.) + allocate (obcs(i)%hcsout_a(iout)%path(npaths), source = 0.) end if if (nmetals > 0) then @@ -264,25 +266,25 @@ subroutine hyd_read_connect(con_file, obtyp, nspu1, nspu, nhyds, ndsave) end if if (nsalts > 0) then !rtb salt allocate (obcs(i)%hcsout_m(iout)%salt(nsalts), source = 0.) - allocate (obcs(i)%hcsout_y(iout)%salt(nsalts), source = 0.) - allocate (obcs(i)%hcsout_a(iout)%salt(nsalts), source = 0.) allocate (obcs(i)%hcsout_m(iout)%salt_min(nsalts), source = 0.) allocate (obcs(i)%hcsout_m(iout)%saltc(nsalts), source = 0.) + allocate (obcs(i)%hcsout_y(iout)%salt(nsalts), source = 0.) allocate (obcs(i)%hcsout_y(iout)%salt_min(nsalts), source = 0.) allocate (obcs(i)%hcsout_y(iout)%saltc(nsalts), source = 0.) + allocate (obcs(i)%hcsout_a(iout)%salt(nsalts), source = 0.) allocate (obcs(i)%hcsout_a(iout)%salt_min(nsalts), source = 0.) allocate (obcs(i)%hcsout_a(iout)%saltc(nsalts), source = 0.) end if if (ncs > 0) then !rtb cs allocate (obcs(i)%hcsout_m(iout)%cs(ncs), source = 0.) - allocate (obcs(i)%hcsout_y(iout)%cs(ncs), source = 0.) - allocate (obcs(i)%hcsout_a(iout)%cs(ncs), source = 0.) allocate (obcs(i)%hcsout_m(iout)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hcsout_m(iout)%csc(ncs), source = 0.) allocate (obcs(i)%hcsout_m(iout)%csc_sorb(ncs), source = 0.) + allocate (obcs(i)%hcsout_y(iout)%cs(ncs), source = 0.) allocate (obcs(i)%hcsout_y(iout)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hcsout_y(iout)%csc(ncs), source = 0.) allocate (obcs(i)%hcsout_y(iout)%csc_sorb(ncs), source = 0.) + allocate (obcs(i)%hcsout_a(iout)%cs(ncs), source = 0.) allocate (obcs(i)%hcsout_a(iout)%cs_sorb(ncs), source = 0.) allocate (obcs(i)%hcsout_a(iout)%csc(ncs), source = 0.) allocate (obcs(i)%hcsout_a(iout)%csc_sorb(ncs), source = 0.) diff --git a/src/hydro_init.f90 b/src/hydro_init.f90 index e78d5bd..18f258b 100644 --- a/src/hydro_init.f90 +++ b/src/hydro_init.f90 @@ -88,7 +88,6 @@ subroutine hydro_init if (bsn_prm%ffcb <= 0.) then sffc = wgn_pms(iwgn)%pcp_an / (wgn_pms(iwgn)%pcp_an + Exp(9.043 - & .002135 * wgn_pms(iwgn)%pcp_an)) - !!S-curve equation Jeff made up. else sffc = bsn_prm%ffcb end if diff --git a/src/hydrograph_module.f90 b/src/hydrograph_module.f90 index ff837ef..b9f2b9c 100644 --- a/src/hydrograph_module.f90 +++ b/src/hydrograph_module.f90 @@ -362,6 +362,8 @@ module hydrograph_module real :: runoff = 0. !irrigation surface runoff |mm real :: eff = 1. !irrigation efficiency as a fraction of irrigation. Jaehak 2022 real :: frac_surq = 0. !fraction of irrigation lost in runoff flow. Jaehak 2022 + real :: no3 = 0. !nitrate concentration in irrigation water |kg Jaehak 2023 + real :: salt = 0. !salt concentration in irrigation water |ppm !hyd_output units are in mm and mg/L type (hyd_output) :: water !irrigation water end type irrigation_water_transfer @@ -785,6 +787,9 @@ module hydrograph_module character (len=15) :: lag = " tons" !! tons |detached large ag character (len=15) :: grv = " tons" !! tons |gravel character (len=15) :: temp = " " !! deg c |temperature + !Jaehak 2023 + !character (len=15) :: salt = " kg" !! deg c |temperature + !character (len=15) :: pest = " mg" !! deg c |temperature end type hyd_header_units1 type (hyd_header_units1) :: hyd_hdr_units1 @@ -807,6 +812,9 @@ module hydrograph_module character (len=15) :: lag = " tons" !! tons |detached large ag character (len=15) :: grv = " tons" !! tons |gravel character (len=15) :: temp = " " !! deg c |temperature + !Jaehak 2023 + !character (len=15) :: salt = " kg" !! deg c |temperature + !character (len=15) :: pest = " mg" !! deg c |temperature end type hyd_header_units3 type (hyd_header_units3) :: hyd_hdr_units3 @@ -967,47 +975,47 @@ module hydrograph_module character (len=11) :: min = " min " end type output_flow_duration_header type (output_flow_duration_header) :: fdc_hdr - + type calibration_header character (len=16) :: name = " name " character (len=12) :: ha = " ha " character (len=12) :: nbyr = " nbyr " character (len=12) :: prec = " precip " - character (len=16) :: meas = " name " - character (len=12) :: srr = " srr " - character (len=12) :: lfr = " lfr " - character (len=12) :: pcr = " pcr " - character (len=12) :: etr = " etr " - character (len=12) :: tfr = " tfr " - character (len=12) :: sed = " sed " - character (len=12) :: orgn = " orgn " - character (len=12) :: orgp = " orgp " - character (len=12) :: no3 = " no3 " - character (len=12) :: solp = " solp " - character (len=16) :: aa = " name " - character (len=12) :: srr_aa = " srr " - character (len=12) :: lfr_aa = " lfr " - character (len=12) :: pcr_aa = " pcr " - character (len=12) :: etr_aa = " etr " - character (len=12) :: tfr_aa = " tfr " - character (len=12) :: sed_aa = " sed " - character (len=12) :: orgn_aa = " orgn " - character (len=12) :: orgp_aa = " orgp " - character (len=12) :: no3_aa = " no3 " - character (len=12) :: solp_aa = " solp " - character (len=12) :: cn_prm_aa = " cn " - character (len=12) :: esco = " esco " - character (len=12) :: lat_len = "lat_len " - character (len=12) :: petco = " petco " - character (len=12) :: slope = " slope " - character (len=12) :: tconc = " tconc " - character (len=12) :: etco = " etco " - character (len=12) :: perco = " perco " - character (len=12) :: revapc = " revapc " - character (len=12) :: cn3_swf = " cn3_swf " + character (len=16) :: meas = " name " + character (len=12) :: srr = " srr " + character (len=12) :: lfr = " lfr " + character (len=12) :: pcr = " pcr " + character (len=12) :: etr = " etr " + character (len=12) :: tfr = " tfr " + character (len=12) :: sed = " sed " + character (len=12) :: orgn = " orgn " + character (len=12) :: orgp = " orgp " + character (len=12) :: no3 = " no3 " + character (len=12) :: solp = " solp " + character (len=16) :: aa = " name " + character (len=12) :: srr_aa = " srr " + character (len=12) :: lfr_aa = " lfr " + character (len=12) :: pcr_aa = " pcr " + character (len=12) :: etr_aa = " etr " + character (len=12) :: tfr_aa = " tfr " + character (len=12) :: sed_aa = " sed " + character (len=12) :: orgn_aa = " orgn " + character (len=12) :: orgp_aa = " orgp " + character (len=12) :: no3_aa = " no3 " + character (len=12) :: solp_aa = " solp " + character (len=12) :: cn_prm_aa = " cn " + character (len=12) :: esco = " esco " + character (len=12) :: lat_len = "lat_len " + character (len=12) :: petco = " petco " + character (len=12) :: slope = " slope " + character (len=12) :: tconc = " tconc " + character (len=12) :: etco = " etco " + character (len=12) :: perco = " perco " + character (len=12) :: revapc = " revapc " + character (len=12) :: cn3_swf = " cn3_swf " end type calibration_header - type (calibration_header) :: calb_hdr - + type (calibration_header) :: calb_hdr + type calibration2_header character (len=16) :: name = " name " character (len=12) :: dakm2 = " da_km2 " @@ -1042,7 +1050,7 @@ module hydrograph_module character (len=12) :: uslep = " uslep " character (len=12) :: uslels = " uslels " end type calibration2_header - type (calibration2_header) :: calb2_hdr + type (calibration2_header) :: calb2_hdr type calibration3_header character (len=16) :: name = " name " @@ -1119,7 +1127,7 @@ module hydrograph_module end type hru_swift_header_baseunit type hru_swift_header_base2 - character (len=16) :: flo = "flo " !! ha-m |volume of water + character (len=17) :: flo = "flo " !! ha-m |volume of water type(hru_swift_header_base) :: base end type hru_swift_header_base2 @@ -1129,7 +1137,7 @@ module hydrograph_module end type hru_swift_header_baseunit2 type hru_swift_header - character(len=16) :: hd_type(5) = ["total_flow ", "percolation ", "surface_runoff ", "lateral_flow ", "tile_flow "] + character(len=17) :: hd_type(5) = ["total_flow ", "percolation ", "surface_runoff ", "lateral_flow ", "tile_flow "] type (hru_swift_header_base) :: exco type (hru_swift_header_baseunit) :: exco_unit type (hru_swift_header_base2) :: dr diff --git a/src/input_file_module.f90 b/src/input_file_module.f90 index 80e5f56..3154700 100644 --- a/src/input_file_module.f90 +++ b/src/input_file_module.f90 @@ -20,7 +20,7 @@ module input_file_module character(len=25) :: parms_bas = "parameters.bsn" end type input_basin type (input_basin) :: in_basin - + !! climate type input_cli character(len=25) :: weat_sta = "weather-sta.cli" @@ -95,7 +95,7 @@ module input_file_module character(len=25) :: hru_ez = "hru-lte.hru" end type input_hru type (input_hru) :: in_hru - + !! exco (recall constant) type input_exco character(len=25) :: exco = "exco.exc" @@ -106,7 +106,7 @@ module input_file_module character(len=25) :: salt = "exco_salt.exc" end type input_exco type (input_exco) :: in_exco - + !! recall (daily, monthly and annual) type input_rec character(len=25) :: recall_rec = "recall.rec" @@ -116,11 +116,11 @@ module input_file_module !! delivery ratio type input_delr character(len=25) :: del_ratio = "delratio.del" - character(len=25) :: om = "dr_om.del" - character(len=25) :: pest = "dr_pest.del" - character(len=25) :: path = "dr_path.del" - character(len=25) :: hmet = "dr_hmet.del" - character(len=25) :: salt = "dr_salt.del" + character(len=25) :: om = "dr_om.del" + character(len=25) :: pest = "dr_pest.del" + character(len=25) :: path = "dr_path.del" + character(len=25) :: hmet = "dr_hmet.del" + character(len=25) :: salt = "dr_salt.del" end type input_delr type (input_delr) :: in_delr @@ -178,9 +178,9 @@ module input_file_module character(len=25) :: fert_frt = "fertilizer.frt" character(len=25) :: till_til = "tillage.til" character(len=25) :: pest = "pesticide.pes" - character(len=25) :: pathcom_db = "pathogens.pth" - character(len=25) :: hmetcom_db = "metals.mtl" - character(len=25) :: saltcom_db = "salt.slt" + character(len=25) :: pathcom_db = "pathogens.pth" + character(len=25) :: hmetcom_db = "metals.mtl" + character(len=25) :: saltcom_db = "salt.slt" character(len=25) :: urban_urb = "urban.urb" character(len=25) :: septic_sep = "septic.sep" character(len=25) :: snow = "snow.sno" @@ -224,17 +224,17 @@ module input_file_module !! initial conditions type input_init - character(len=25) :: plant = "plant.ini" + character(len=25) :: plant = "plant.ini" character(len=25) :: soil_plant_ini = "soil_plant.ini" character(len=25) :: om_water = "om_water.ini" - character(len=25) :: pest_soil = "pest_hru.ini" - character(len=25) :: pest_water = "pest_water.ini" - character(len=25) :: path_soil = "path_hru.ini" - character(len=25) :: path_water = "path_water.ini" - character(len=25) :: hmet_soil = "hmet_hru.ini" - character(len=25) :: hmet_water = "hmet_water.ini" - character(len=25) :: salt_soil = "salt_hru.ini" - character(len=25) :: salt_water = "salt_water.ini" + character(len=25) :: pest_soil = "pest_hru.ini" + character(len=25) :: pest_water = "pest_water.ini" + character(len=25) :: path_soil = "path_hru.ini" + character(len=25) :: path_water = "path_water.ini" + character(len=25) :: hmet_soil = "hmet_hru.ini" + character(len=25) :: hmet_water = "hmet_water.ini" + character(len=25) :: salt_soil = "salt_hru.ini" + character(len=25) :: salt_water = "salt_water.ini" end type input_init type (input_init) :: in_init diff --git a/src/lcu_read_softcal.f90 b/src/lcu_read_softcal.f90 index 033969d..c001615 100644 --- a/src/lcu_read_softcal.f90 +++ b/src/lcu_read_softcal.f90 @@ -25,7 +25,7 @@ subroutine lcu_read_softcal imax = 0 mcal = 0 mreg = 0 - + inquire (file=in_chg%water_balance_sft, exist=i_exist) if (.not. i_exist .or. in_chg%water_balance_sft == "null") then allocate (lscal(0:0)) diff --git a/src/ls_read_parms_cal.f90 b/src/ls_read_parms_cal.f90 index 266c50d..8ff6629 100644 --- a/src/ls_read_parms_cal.f90 +++ b/src/ls_read_parms_cal.f90 @@ -38,7 +38,7 @@ subroutine ls_read_lsparms_cal if (eof < 0) exit end do - end if + end if close(107) return diff --git a/src/lsreg_output.f90 b/src/lsreg_output.f90 index abdc39b..e4806f7 100644 --- a/src/lsreg_output.f90 +++ b/src/lsreg_output.f90 @@ -336,6 +336,6 @@ subroutine lsreg_output 100 format (4i6,2a16,22f12.3) 101 format (4i6,2a16,24f12.3) 102 format (4i6,2a16,24f12.3) -103 format (4i6,i8,4x,a,5x,f12.3) +!*** tu Wunused-label: 103 format (4i6,i8,4x,a,5x,f12.3) end subroutine lsreg_output \ No newline at end of file diff --git a/src/lsu_output.f90 b/src/lsu_output.f90 index 0a9bfb3..3546bd9 100644 --- a/src/lsu_output.f90 +++ b/src/lsu_output.f90 @@ -260,6 +260,6 @@ subroutine lsu_output 102 format (1x,4i6,i7,a,2x,a,40f12.3) !103 format (4i6,i8,a,2x,a,6f12.3,29f17.3) 103 format (4i6,i8,a,2x,a,4f12.3,23f17.3) -104 format (4i6,i8,a,2x,a,6f12.3,29f17.3) +!*** tu Wunused-label: 104 format (4i6,i8,a,2x,a,6f12.3,29f17.3) end subroutine lsu_output \ No newline at end of file diff --git a/src/lsu_read_elements.f90 b/src/lsu_read_elements.f90 index 9bc6af1..1d6346c 100644 --- a/src/lsu_read_elements.f90 +++ b/src/lsu_read_elements.f90 @@ -90,7 +90,7 @@ subroutine lsu_read_elements exit end do - end if + end if !!read data for each element in all landscape cataloging units inquire (file=in_regs%ele_lsu, exist=i_exist) diff --git a/src/manure_allocation_module.f90 b/src/manure_allocation_module.f90 index c891a13..a452e82 100644 --- a/src/manure_allocation_module.f90 +++ b/src/manure_allocation_module.f90 @@ -66,56 +66,56 @@ module manure_allocation_module type (manure_allocation), dimension(:), allocatable :: mallo !dimension by water allocation objects type mallo_header - character(len=6) :: day = " jday" - character(len=6) :: mo = " mon" - character(len=6) :: day_mo = " day " - character(len=6) :: yrc = " yr " - character(len=8) :: idmd = " unit " - character(len=16) :: dmd_typ = "dmd_typ " - character(len=16) :: dmd_num = " dmd_num " + character(len=6) :: day = " jday" + character(len=6) :: mo = " mon" + character(len=6) :: day_mo = " day " + character(len=6) :: yrc = " yr " + character(len=8) :: idmd = " unit " + character(len=16) :: dmd_typ = "dmd_typ " + character(len=16) :: dmd_num = " dmd_num " character(len=12) :: src1_obj = " src1_obj " - character(len=12) :: src1_typ = " src1_typ " - character(len=12) :: src1_num = " src1_num " - character(len=15) :: dmd1 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src1_typ = " src1_typ " + character(len=12) :: src1_num = " src1_num " + character(len=15) :: dmd1 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s1out = "src1_withdraw " !! ha-m |withdrawal from source 1 character(len=12) :: s1un = " src1_unmet" !! ha-m |unmet from source 1 - character(len=12) :: src2_typ = " src2_typ " - character(len=12) :: src2_num = " src2_num " - character(len=15) :: dmd2 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src2_typ = " src2_typ " + character(len=12) :: src2_num = " src2_num " + character(len=15) :: dmd2 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s2out = "src2_withdraw " !! ha-m |withdrawal from source 2 character(len=12) :: s2un = " src2_unmet" !! ha-m |unmet from source 2 - character(len=12) :: src3_typ = " src3_typ " - character(len=12) :: src3_num = " src3_num " - character(len=15) :: dmd3 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src3_typ = " src3_typ " + character(len=12) :: src3_num = " src3_num " + character(len=15) :: dmd3 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s3out = "src3_withdraw " !! ha-m |withdrawal from source 3 character(len=12) :: s3un = " src3_unmet" !! ha-m |unmet from source 3 end type mallo_header type (mallo_header) :: mallo_hdr type mallo_header_units - character (len=8) :: day = " " - character (len=8) :: mo = " " - character (len=8) :: day_mo = " " - character (len=8) :: yrc = " " - character (len=8) :: idmd = " " - character (len=16) :: dmd_typ = " " - character (len=16) :: dmd_num = " " + character (len=8) :: day = " " + character (len=8) :: mo = " " + character (len=8) :: day_mo = " " + character (len=8) :: yrc = " " + character (len=8) :: idmd = " " + character (len=16) :: dmd_typ = " " + character (len=16) :: dmd_num = " " character (len=12) :: src1_obj = " " - character (len=12) :: src1_typ = " " - character (len=8) :: src1_num = " " + character (len=12) :: src1_typ = " " + character (len=8) :: src1_num = " " character (len=15) :: dmd1 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s1out = "m^3 " !! ha-m |withdrawal from source 1 + character (len=15) :: s1out = "m^3 " !! ha-m |withdrawal from source 1 character (len=9) :: s1un = "m^3 " !! ha-m |unmet from source 1 - character (len=15) :: src2_typ = " " - character (len=15) :: src2_num = " " + character (len=15) :: src2_typ = " " + character (len=15) :: src2_num = " " character (len=15) :: dmd2 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s2out = "m^3 " !! ha-m |withdrawal from source 2 - character (len=10) :: s2un = "m^3 " !! ha-m |unmet from source 2 - character (len=15) :: src3_typ = " " - character (len=15) :: src3_num = " " + character (len=15) :: s2out = "m^3 " !! ha-m |withdrawal from source 2 + character (len=15) :: s2un = "m^3 " !! ha-m |unmet from source 2 + character (len=15) :: src3_typ = " " + character (len=15) :: src3_num = " " character (len=15) :: dmd3 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s3out = "m^3 " !! ha-m |withdrawal from source 3 - character (len=10) :: s3un = "m^3 " !! ha-m |unmet from source 3 + character (len=15) :: s3out = "m^3 " !! ha-m |withdrawal from source 3 + character (len=15) :: s3un = "m^3 " !! ha-m |unmet from source 3 end type mallo_header_units type (mallo_header_units) :: mallo_hdr_units diff --git a/src/mgt_killop.f90 b/src/mgt_killop.f90 index 10ad6fc..8dc7aff 100644 --- a/src/mgt_killop.f90 +++ b/src/mgt_killop.f90 @@ -27,7 +27,7 @@ subroutine mgt_killop (jj, iplant) !! allocate dead roots, N, P to soil layers do ly = 1, soil(j)%nly - soil1(j)%rsd(ly) = soil(j)%ly(ly)%rtfr * pl_mass(j)%root(ipl) + soil1(j)%rsd(ly) + soil1(j)%rsd(ly) = soil(j)%ly(ly)%rtfr * pl_mass(j)%root(ipl) + soil1(j)%rsd(ly) end do !! add above ground mass to residue pool diff --git a/src/mgt_newtillmix.f90 b/src/mgt_newtillmix.f90 index 282ccc5..e18d202 100644 --- a/src/mgt_newtillmix.f90 +++ b/src/mgt_newtillmix.f90 @@ -124,8 +124,8 @@ subroutine mgt_newtillmix (jj, bmix, idtill) if (soil(jj)%phys(l)%d <= dtil) then !! msm = mass of soil mixed for the layer - !! msn = mass of soil not mixed for the layer - sol_msm(l) = emix * sol_mass(l) + !! msn = mass of soil not mixed for the layer + sol_msm(l) = emix * sol_mass(l) sol_msn(l) = sol_mass(l) - sol_msm(l) frac_dep(l) = soil(jj)%phys(l)%thick / dtil else if (soil(jj)%phys(l)%d > dtil .and. soil(jj)%phys(l-1)%d < dtil) then @@ -165,21 +165,21 @@ subroutine mgt_newtillmix (jj, bmix, idtill) !!by zhang !!============== if (bsn_cc%cswat == 2) then - smix(20+npmx+1) = smix(20+npmx+1) + soil1(jj)%str(l)%c * frac_mixed - smix(20+npmx+2) = smix(20+npmx+2) + soil1(jj)%lig(l)%c * frac_mixed - smix(20+npmx+3) = smix(20+npmx+3) + soil1(jj)%lig(l)%n* frac_mixed - smix(20+npmx+4) = smix(20+npmx+4) + soil1(jj)%meta(l)%c * frac_mixed - smix(20+npmx+5) = smix(20+npmx+5) + soil1(jj)%meta(l)%m * frac_mixed - smix(20+npmx+6) = smix(20+npmx+6) + soil1(jj)%lig(l)%m * frac_mixed - smix(20+npmx+7) = smix(20+npmx+7) + soil1(jj)%str(l)%m * frac_mixed - - smix(20+npmx+8) = smix(20+npmx+8) + soil1(jj)%str(l)%n * frac_mixed - smix(20+npmx+9) = smix(20+npmx+9) + soil1(jj)%meta(l)%n * frac_mixed - smix(20+npmx+10) = smix(20+npmx+10) +soil1(jj)%microb(l)%n* frac_mixed - smix(20+npmx+11) = smix(20+npmx+11) + soil1(jj)%hact(l)%n * frac_mixed - smix(20+npmx+12) = smix(20+npmx+12) + soil1(jj)%hsta(l)%n * frac_mixed - end if - !!by zhang + smix(20+npmx+1) = smix(20+npmx+1) + soil1(jj)%str(l)%c * frac_mixed + smix(20+npmx+2) = smix(20+npmx+2) + soil1(jj)%lig(l)%c * frac_mixed + smix(20+npmx+3) = smix(20+npmx+3) + soil1(jj)%lig(l)%n* frac_mixed + smix(20+npmx+4) = smix(20+npmx+4) + soil1(jj)%meta(l)%c * frac_mixed + smix(20+npmx+5) = smix(20+npmx+5) + soil1(jj)%meta(l)%m * frac_mixed + smix(20+npmx+6) = smix(20+npmx+6) + soil1(jj)%lig(l)%m * frac_mixed + smix(20+npmx+7) = smix(20+npmx+7) + soil1(jj)%str(l)%m * frac_mixed + + smix(20+npmx+8) = smix(20+npmx+8) + soil1(jj)%str(l)%n * frac_mixed + smix(20+npmx+9) = smix(20+npmx+9) + soil1(jj)%meta(l)%n * frac_mixed + smix(20+npmx+10) = smix(20+npmx+10) +soil1(jj)%microb(l)%n* frac_mixed + smix(20+npmx+11) = smix(20+npmx+11) + soil1(jj)%hact(l)%n * frac_mixed + smix(20+npmx+12) = smix(20+npmx+12) + soil1(jj)%hsta(l)%n * frac_mixed + end if + !!by zhang !!============= end do @@ -189,7 +189,7 @@ subroutine mgt_newtillmix (jj, bmix, idtill) smix(19) = smix(19) / dtil do l = 1, soil(jj)%nly - + ! reconstitute each soil layer frac_non_mixed = sol_msn(l) / sol_mass(l) @@ -234,8 +234,8 @@ subroutine mgt_newtillmix (jj, bmix, idtill) !!by zhang !!============== - end do - + end do + if (bsn_cc%cswat == 1) then call mgt_tillfactor(jj,bmix,emix,dtil) end if diff --git a/src/mgt_newtillmix_wet.f90 b/src/mgt_newtillmix_wet.f90 index 80d84bc..95cd2e6 100644 --- a/src/mgt_newtillmix_wet.f90 +++ b/src/mgt_newtillmix_wet.f90 @@ -94,8 +94,8 @@ subroutine mgt_newtillmix_wet (jj, idtill) if (soil(jj)%phys(l)%d <= dtil) then !! msm = mass of soil mixed for the layer - !! msn = mass of soil not mixed for the layer - sol_msm(l) = emix * sol_mass(l) + !! msn = mass of soil not mixed for the layer + sol_msm(l) = emix * sol_mass(l) sol_msn(l) = sol_mass(l) - sol_msm(l) frac_dep(l) = soil(jj)%phys(l)%thick / dtil frac_dep1(l) = soil(jj)%phys(l)%thick / tdep @@ -137,20 +137,20 @@ subroutine mgt_newtillmix_wet (jj, idtill) !!by zhang !!============== if (bsn_cc%cswat == 2) then - smix(20+npmx+1) = smix(20+npmx+1) + soil1(jj)%str(l)%c * frac_mixed - smix(20+npmx+2) = smix(20+npmx+2) + soil1(jj)%lig(l)%c * frac_mixed - smix(20+npmx+3) = smix(20+npmx+3) + soil1(jj)%lig(l)%n* frac_mixed - smix(20+npmx+4) = smix(20+npmx+4) + soil1(jj)%meta(l)%c * frac_mixed - smix(20+npmx+5) = smix(20+npmx+5) + soil1(jj)%meta(l)%m * frac_mixed - smix(20+npmx+6) = smix(20+npmx+6) + soil1(jj)%lig(l)%m * frac_mixed - smix(20+npmx+7) = smix(20+npmx+7) + soil1(jj)%str(l)%m * frac_mixed - - smix(20+npmx+8) = smix(20+npmx+8) + soil1(jj)%str(l)%n * frac_mixed - smix(20+npmx+9) = smix(20+npmx+9) + soil1(jj)%meta(l)%n * frac_mixed - smix(20+npmx+10) = smix(20+npmx+10) +soil1(jj)%microb(l)%n* frac_mixed - smix(20+npmx+11) = smix(20+npmx+11) + soil1(jj)%hact(l)%n * frac_mixed - smix(20+npmx+12) = smix(20+npmx+12) + soil1(jj)%hsta(l)%n * frac_mixed - end if + smix(20+npmx+1) = smix(20+npmx+1) + soil1(jj)%str(l)%c * frac_mixed + smix(20+npmx+2) = smix(20+npmx+2) + soil1(jj)%lig(l)%c * frac_mixed + smix(20+npmx+3) = smix(20+npmx+3) + soil1(jj)%lig(l)%n* frac_mixed + smix(20+npmx+4) = smix(20+npmx+4) + soil1(jj)%meta(l)%c * frac_mixed + smix(20+npmx+5) = smix(20+npmx+5) + soil1(jj)%meta(l)%m * frac_mixed + smix(20+npmx+6) = smix(20+npmx+6) + soil1(jj)%lig(l)%m * frac_mixed + smix(20+npmx+7) = smix(20+npmx+7) + soil1(jj)%str(l)%m * frac_mixed + + smix(20+npmx+8) = smix(20+npmx+8) + soil1(jj)%str(l)%n * frac_mixed + smix(20+npmx+9) = smix(20+npmx+9) + soil1(jj)%meta(l)%n * frac_mixed + smix(20+npmx+10) = smix(20+npmx+10) +soil1(jj)%microb(l)%n* frac_mixed + smix(20+npmx+11) = smix(20+npmx+11) + soil1(jj)%hact(l)%n * frac_mixed + smix(20+npmx+12) = smix(20+npmx+12) + soil1(jj)%hsta(l)%n * frac_mixed + end if end do ! sand, silt and clay are % so divide by tillage depth @@ -167,7 +167,7 @@ subroutine mgt_newtillmix_wet (jj, idtill) do l = 1, soil(jj)%nly - + ! reconstitute each soil layer frac_non_mixed = sol_msn(l) / sol_mass(l) @@ -209,8 +209,8 @@ subroutine mgt_newtillmix_wet (jj, idtill) soil1(jj)%hact(l)%n = soil1(jj)%hact(l)%n * frac_non_mixed + smix(20 + npmx + 11) * frac_dep(l) soil1(jj)%hsta(l)%n = soil1(jj)%hsta(l)%n * frac_non_mixed + smix(20 + npmx+12) * frac_dep(l) end if - end do - + end do + !if (bsn_cc%cswat == 1) then ! call mgt_tillfactor(jj,bmix,emix,dtil) !end if diff --git a/src/mgt_sched.f90 b/src/mgt_sched.f90 index cbbc30b..9484244 100644 --- a/src/mgt_sched.f90 +++ b/src/mgt_sched.f90 @@ -155,12 +155,13 @@ subroutine mgt_sched (isched) harveff = mgt%op3 call mgt_harvresidue (j, harveff) case ("tree") + call mgt_harvbiomass (j, ipl, iharvop) case ("tuber") call mgt_harvtuber (j, ipl, iharvop) case ("peanuts") call mgt_harvtuber (j, ipl, iharvop) case ("stripper") - call mgt_harvgrain (j, ipl, iharvop) + call mgt_harvbiomass (j, ipl, iharvop) case ("picker") call mgt_harvgrain (j, ipl, iharvop) end select @@ -436,19 +437,24 @@ subroutine mgt_sched (isched) !! set weir height and adjust principal spillway storage and depth wet_ob(j)%weir_hgt = mgt%op3 / 1000. !weir height, m - wet_ob(j)%pvol = hru(j)%area_ha * wet_ob(j)%weir_hgt * 10. + wet_ob(j)%pvol = hru(j)%area_ha * wet_ob(j)%weir_hgt * 10000. !m3 if (wet_ob(j)%evol < wet_ob(j)%pvol*1.1) then wet_ob(j)%evol = wet_ob(j)%pvol * 1.1 endif case ("irrp") !! continuous irrigation to maintain surface ponding in rice fields Jaehak 2022 - hru(j)%irr_src = mgt%op_plant !irrigation source: cha; res; aqu; or unlim - hru(j)%irr_hmin = irrop_db(mgt%op1)%dep_mm !threshold ponding depth, mm + hru(j)%irr_src = mgt%op_plant !irrigation source: cha; res; aqu; or unlim + hru(j)%irr_isc = mgt%op3 !irrigation source object ID: cha; res; aqu; or unlim + hru(j)%irr_hmax = irrop_db(mgt%op1)%amt_mm !irrigation amount in irr.org, mm + hru(j)%irr_hmin = hru(j)%irr_hmax * 0.9 !threshold ponding depth, mm irrig(j)%eff = irrop_db(mgt%op1)%eff irrig(j)%frac_surq = irrop_db(mgt%op1)%surq + irrig(j)%salt = irrop_db(mgt%op1)%salt !ppm salt Jaehak 2023 + irrig(j)%no3 = irrop_db(mgt%op1)%no3 !ppm no3 pcom(j)%days_irr = 1 ! reset days since last irrigation if (mgt%op3 < 0) then hru(j)%irr_hmax = irrop_db(mgt%op1)%amt_mm !irrigation amount in irr.org, mm + if (hru(j)%irr_hmax>0) hru(j)%paddy_irr = 1 !paddy irrigation is on with manual scheduling else hru(j)%irr_hmax = mgt%op3 !target ponding depth, mm if (mgt%op3 > 0) then diff --git a/src/mgt_tillfactor.f90 b/src/mgt_tillfactor.f90 index eff98c8..08d6df8 100644 --- a/src/mgt_tillfactor.f90 +++ b/src/mgt_tillfactor.f90 @@ -1,24 +1,24 @@ subroutine mgt_tillfactor(jj,bmix,emix,dtil) - !!!!!!!!!!!!!!!!!!!!!!! - ! Armen 16 January 2008 - ! This procedure increases tillage factor (tillagef(l,jj) per layer for each operation - ! The tillage factor settling will depend of soil moisture (tentatively) and must be called every day - ! For simplicity the settling is calculated now at the soil carbon subroutine because soil water content is available + !!!!!!!!!!!!!!!!!!!!!!! + ! Armen 16 January 2008 + ! This procedure increases tillage factor (tillagef(l,jj) per layer for each operation + ! The tillage factor settling will depend of soil moisture (tentatively) and must be called every day + ! For simplicity the settling is calculated now at the soil carbon subroutine because soil water content is available - ! The tillage factor depends on the cumulative soil disturbance rating = csdr - ! For simplicity, csdr is a function of emix - ! First step is to calculate "current" csdr by inverting tillage factor function - ! The effect of texture on tillage factor (ZZ) is removed first (and recovered at the end of the procedure) - ! YY = tillagef(l,jj) / ZZ - ! Since the tillage factor function is non linear, iterations are needed - ! XX = 0.5 is the initial value that works OK for the range of values observed - ! If a layer is only partially tilled then emix is corrected accordingly + ! The tillage factor depends on the cumulative soil disturbance rating = csdr + ! For simplicity, csdr is a function of emix + ! First step is to calculate "current" csdr by inverting tillage factor function + ! The effect of texture on tillage factor (ZZ) is removed first (and recovered at the end of the procedure) + ! YY = tillagef(l,jj) / ZZ + ! Since the tillage factor function is non linear, iterations are needed + ! XX = 0.5 is the initial value that works OK for the range of values observed + ! If a layer is only partially tilled then emix is corrected accordingly - use soil_module + use soil_module implicit none - integer, intent (in) :: jj !none |HRU number + integer, intent (in) :: jj !none |HRU number real, intent (in) :: bmix !none |biological mixing efficiency: this ! |number is zero for tillage operations integer :: l = 0 !none |counter @@ -34,43 +34,43 @@ subroutine mgt_tillfactor(jj,bmix,emix,dtil) real :: xx2 = 0. ! | real :: csdr = 0. ! | - emix = emix - bmix ! this is to avoid affecting tillage factor with biological mixing - - if (emix > 0.) then + emix = emix - bmix ! this is to avoid affecting tillage factor with biological mixing + + if (emix > 0.) then - do l = 1, soil(j)%nly - - if (soil(jj)%phys(l)%d <= dtil) then - emix = emix + do l = 1, soil(j)%nly + + if (soil(jj)%phys(l)%d <= dtil) then + emix = emix else if (soil(jj)%phys(l)%d > dtil .and. soil(jj)%phys(l-1)%d < dtil) then - emix = emix * (dtil - soil(jj)%phys(l-1)%d) / soil(jj)%phys(l)%thick - else - emix = 0. - end if - - ! to save computation time if emix = 0 here then the other layers can be avoided - ! tillage always proceeds from top to bottom - if (emix == 0.) exit + emix = emix * (dtil - soil(jj)%phys(l-1)%d) / soil(jj)%phys(l)%thick + else + emix = 0. + end if + + ! to save computation time if emix = 0 here then the other layers can be avoided + ! tillage always proceeds from top to bottom + if (emix == 0.) exit - xx = 0. - zz = 3. + (8. - 3.)*exp(-5.5*soil(jj)%phys(1)%clay/100.) - yy = soil(jj)%ly(l)%tillagef / zz - m1 = 1 - m2 = 2 + xx = 0. + zz = 3. + (8. - 3.)*exp(-5.5*soil(jj)%phys(1)%clay/100.) + yy = soil(jj)%ly(l)%tillagef / zz + m1 = 1 + m2 = 2 - ! empirical solution for x when y is known and y=x/(x+exp(m1-m2*x)) - if (yy > 0.01) then - xx1 = yy ** exp(-0.13 + 1.06 * yy) - xx2 = exp(0.64 + 0.64 * yy ** 100.) - xx = xx1 * xx2 - end if + ! empirical solution for x when y is known and y=x/(x+exp(m1-m2*x)) + if (yy > 0.01) then + xx1 = yy ** exp(-0.13 + 1.06 * yy) + xx2 = exp(0.64 + 0.64 * yy ** 100.) + xx = xx1 * xx2 + end if - csdr = xx + emix - soil(jj)%ly(l)%tillagef = zz * (csdr / (csdr + exp(m1 - m2*csdr))) + csdr = xx + emix + soil(jj)%ly(l)%tillagef = zz * (csdr / (csdr + exp(m1 - m2*csdr))) - end do - - end if - - return - end subroutine mgt_tillfactor \ No newline at end of file + end do + + end if + + return + end subroutine mgt_tillfactor \ No newline at end of file diff --git a/src/mgt_transplant.f90 b/src/mgt_transplant.f90 index fd8b99e..2a5c21d 100644 --- a/src/mgt_transplant.f90 +++ b/src/mgt_transplant.f90 @@ -53,7 +53,7 @@ subroutine mgt_transplant (itrans) !! initialize plant mass call pl_root_gro(j) call pl_seed_gro(j) - call pl_partition(j) + call pl_partition(j, 1) return end subroutine mgt_transplant \ No newline at end of file diff --git a/src/nut_denit.f90 b/src/nut_denit.f90 index 57f1821..8271a18 100644 --- a/src/nut_denit.f90 +++ b/src/nut_denit.f90 @@ -7,19 +7,19 @@ subroutine nut_denit(k,j,cdg,wdn,void) implicit none - integer :: k !none |counter + integer :: k !none |counter integer :: j !none |HRU number - real :: cdg !none |soil temperature factor + real :: cdg !none |soil temperature factor real :: wdn !kg N/ha |amount of nitrogen lost from nitrate pool in ! |layer due to denitrification real :: void ! | real :: vof = 0. ! | wdn = 0. - vof = 1. / (1. + (void/0.04)**5) - wdn = soil1(j)%mn(k)%no3 * (1. - Exp(-bsn_prm%cdn * cdg * vof * & + vof = 1. / (1. + (void/0.04)**5) + wdn = soil1(j)%mn(k)%no3 * (1. - Exp(-bsn_prm%cdn * cdg * vof * & soil1(j)%tot(k)%c)) - soil1(j)%mn(k)%no3 = max(0.0001,soil1(j)%mn(k)%no3 - wdn) + soil1(j)%mn(k)%no3 = max(0.0001,soil1(j)%mn(k)%no3 - wdn) - return - end subroutine nut_denit \ No newline at end of file + return + end subroutine nut_denit \ No newline at end of file diff --git a/src/nut_nlch.f90 b/src/nut_nlch.f90 index 382f434..6c5acb5 100644 --- a/src/nut_nlch.f90 +++ b/src/nut_nlch.f90 @@ -71,7 +71,7 @@ subroutine nut_nlch !! add nitrate leached from layer above soil1(j)%mn(jj)%no3 = soil1(j)%mn(jj)%no3 + percnlyr - if (soil1(j)%mn(jj)%no3 < 1.e-6) soil1(j)%mn(jj)%no3 = 0.0 + if (soil1(j)%mn(jj)%no3 < 1.e-6) soil1(j)%mn(jj)%no3 = 0.0 !! determine concentration of nitrate in mobile water if (jj == 1) then diff --git a/src/nut_nminrl.f90 b/src/nut_nminrl.f90 index 6e7204e..90e0ad0 100644 --- a/src/nut_nminrl.f90 +++ b/src/nut_nminrl.f90 @@ -30,7 +30,6 @@ subroutine nut_nminrl !! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ use septic_data_module - use plant_data_module use basin_module use organic_mineral_mass_module use hru_module, only : rsdco_plcom, i_sep, ihru, ipl, isep @@ -74,89 +73,11 @@ subroutine nut_nminrl j = ihru nactfr = .02 !zero transformations for summing layers - hnb_d(j)%rsd_nitorg_n = 0. - hnb_d(j)%rsd_laborg_p = 0. hnb_d(j)%act_nit_n = 0. hnb_d(j)%org_lab_p = 0. hnb_d(j)%act_sta_n = 0. hnb_d(j)%denit = 0. - !! mineralization can occur only if temp above 0 deg - if (soil(j)%phys(1)%tmp > 0.) then - !! compute residue decomp and mineralization of fresh organic n and p of flat residue - do ipl = 1, pcom(j)%npl !! we need to decompose each plant - rmn1 = 0. - rmp = 0. - if (rsd1(j)%tot(ipl)%n > 1.e-4) then - cnr = rsd1(j)%tot(ipl)%c / rsd1(j)%tot(ipl)%n - if (cnr > 500.) cnr = 500. - cnrf = Exp(-.693 * (cnr - 25.) / 25.) - else - cnrf = 1. - end if - - if (rsd1(j)%tot(ipl)%p > 1.e-4) then - cpr = rsd1(j)%tot(ipl)%c / rsd1(j)%tot(ipl)%p - if (cpr > 5000.) cpr = 5000. - cprf = Exp(-.693 * (cpr - 200.) / 200.) - else - cprf = 1. - end if - - !! compute soil water factor - if (soil(j)%phys(1)%st < 0.) soil(j)%phys(1)%st = .0000001 - sut = .1 + .9 * Sqrt(soil(j)%phys(1)%st / soil(j)%phys(1)%fc) - sut = Max(.05, sut) - - !!compute soil temperature factor - xx = soil(j)%phys(1)%tmp - cdg = .9 * xx / (xx + Exp(9.93 - .312 * xx)) + .1 - cdg = Max(.1, cdg) - - !! compute combined factor - xx = cdg * sut - if (xx < 0.) xx = 0. - if (xx > 1.e6) xx = 1.e6 - csf = Sqrt(xx) - ca = Min(cnrf, cprf, 1.) - !! compute residue decomp and mineralization for each plant - if (pcom(j)%npl > 0) then - idp = pcom(j)%plcur(ipl)%idplt - decr = pldb(idp)%rsdco_pl * ca * csf - else - decr = 0.05 * ca * csf - end if - decr = Max(bsn_prm%decr_min, decr) - decr = Min(decr, 1.) - - !! mineralization of mass and carbon - rsd1(j)%tot(ipl)%m = Max(1.e-6, rsd1(j)%tot(ipl)%m) - rdc = decr * rsd1(j)%tot(ipl)%m - rsd1(j)%tot(ipl)%m = rsd1(j)%tot(ipl)%m - rdc - if (rsd1(j)%tot(ipl)%m < 0.) rsd1(j)%tot(ipl)%m = 0. - rsd1(j)%tot(ipl)%c = (1. - decr) * rsd1(j)%tot(ipl)%c - if (rsd1(j)%tot(ipl)%c < 0.) rsd1(j)%tot(ipl)%c = 0. - soil1(j)%hact(1)%c = soil1(j)%hact(1)%c + decr * rsd1(j)%tot(ipl)%c - - !! mineralization of residue n and p - rmn1 = decr * rsd1(j)%tot(ipl)%n - rsd1(j)%tot(ipl)%n = Max(1.e-6, rsd1(j)%tot(ipl)%n) - rsd1(j)%tot(ipl)%n = rsd1(j)%tot(ipl)%n - rmn1 - soil1(j)%mn(1)%no3 = soil1(j)%mn(1)%no3 + .8 * rmn1 - soil1(j)%hact(1)%n = soil1(j)%hact(1)%n + .2 * rmn1 - - rsd1(j)%tot(ipl)%p = Max(1.e-6, rsd1(j)%tot(ipl)%p) - rmp = decr * rsd1(j)%tot(ipl)%p - rsd1(j)%tot(ipl)%p = rsd1(j)%tot(ipl)%p - rmp - soil1(j)%mp(1)%lab = soil1(j)%mp(1)%lab + .8 * rmp - soil1(j)%hact(1)%p = soil1(j)%hact(1)%p + .2 * rmp - - hnb_d(j)%rsd_nitorg_n = hnb_d(j)%rsd_nitorg_n + .8 * rmn1 - hnb_d(j)%rsd_laborg_p = hnb_d(j)%rsd_laborg_p + .8 * rmp - - end do ! ipl = 1, pcom(j)%npl - end if - !! compute humus mineralization of organic soil pools do k = 1, soil(j)%nly @@ -170,8 +91,8 @@ subroutine nut_nminrl if (soil(j)%phys(kk)%tmp > 0.) then !! compute soil water factor sut = 0. - !! change for domain error 1/29/09 gsm check with Jeff !!! - if (soil(j)%phys(kk)%st < 0.) soil(j)%phys(kk)%st = .0000001 + !! change for domain error 1/29/09 gsm check with Jeff !!! + if (soil(j)%phys(kk)%st < 0.) soil(j)%phys(kk)%st = .0000001 sut = .1 + .9 * Sqrt(soil(j)%phys(kk)%st / soil(j)%phys(kk)%fc) sut = Max(.05, sut) @@ -252,30 +173,20 @@ subroutine nut_nminrl rmn1 = decr * (soil1(j)%str(k)%n + soil1(j)%lig(k)%n + soil1(j)%meta(k)%n) rmp = decr * (soil1(j)%str(k)%p + soil1(j)%lig(k)%p + soil1(j)%meta(k)%p) - soil1(j)%str(k)%n = soil1(j)%str(k)%n * (1. - decr) - soil1(j)%lig(k)%n = soil1(j)%lig(k)%n * (1. - decr) - soil1(j)%meta(k)%n = soil1(j)%meta(k)%n * (1. - decr) - soil1(j)%str(k)%p = soil1(j)%str(k)%p * (1. - decr) - soil1(j)%lig(k)%p = soil1(j)%lig(k)%p * (1. - decr) - soil1(j)%meta(k)%p = soil1(j)%meta(k)%p * (1. - decr) - - ! soil1(j)%mn(k)%no3 = soil1(j)%mn(k)%no3 + .8 * rmn1 - ! soil1(j)%hact(k)%n = soil1(j)%hact(k)%n + .2 * rmn1 - ! soil1(j)%mp(k)%lab = soil1(j)%mp(k)%lab + .8 * rmp - ! soil1(j)%hsta(k)%p = soil1(j)%hsta(k)%p + .2 * rmp - - ! hnb_d(j)%rsd_nitorg_n = hnb_d(j)%rsd_nitorg_n + rmn1 - ! hnb_d(j)%rsd_laborg_p = hnb_d(j)%rsd_laborg_p + rmp + soil1(j)%mn(k)%no3 = soil1(j)%mn(k)%no3 + .8 * rmn1 + soil1(j)%hact(k)%n = soil1(j)%hact(k)%n + .2 * rmn1 + soil1(j)%mp(k)%lab = soil1(j)%mp(k)%lab + .8 * rmp + soil1(j)%hsta(k)%p = soil1(j)%hsta(k)%p + .2 * rmp !! compute denitrification wdn = 0. - if (i_sep(j) /= k .or. sep(isep)%opt /= 1) then - if (sut >= bsn_prm%sdnco) then - wdn = soil1(j)%mn(k)%no3 * (1.-Exp(-bsn_prm%cdn * cdg * soil1(j)%cbn(k) / 100.)) - else - wdn = 0. - endif - soil1(j)%mn(k)%no3 = max(0.0001,soil1(j)%mn(k)%no3 - wdn) + if (i_sep(j) /= k .or. sep(isep)%opt /= 1) then + if (sut >= bsn_prm%sdnco) then + wdn = soil1(j)%mn(k)%no3 * (1.-Exp(-bsn_prm%cdn * cdg * soil1(j)%cbn(k) / 100.)) + else + wdn = 0. + endif + soil1(j)%mn(k)%no3 = max(0.0001,soil1(j)%mn(k)%no3 - wdn) end if hnb_d(j)%denit = hnb_d(j)%denit + wdn diff --git a/src/nut_orgnc.f90 b/src/nut_orgnc.f90 index e2997a9..7e752ea 100644 --- a/src/nut_orgnc.f90 +++ b/src/nut_orgnc.f90 @@ -42,12 +42,12 @@ subroutine nut_orgnc conc = xx * er / wt1 sedorgn(j) = .001 * conc * sedyld(j) / hru(j)%area_ha - !! update soil nitrogen pools only for HRU calculations + !! update soil nitrogen pools only for HRU calculations if (xx > 1.e-6) then xx1 = (1. - sedorgn(j) / xx) - soil1(j)%tot(1)%n = soil1(j)%tot(1)%n * xx1 - rsd1(j)%tot(1)%n = rsd1(j)%tot(1)%n * xx1 - rsd1(j)%man%n = rsd1(j)%man%n * xx1 + soil1(j)%tot(1)%n = soil1(j)%tot(1)%n * xx1 + rsd1(j)%tot(1)%n = rsd1(j)%tot(1)%n * xx1 + rsd1(j)%man%n = rsd1(j)%man%n * xx1 end if return diff --git a/src/nut_orgnc2.f90 b/src/nut_orgnc2.f90 index 6716e52..87b14ea 100644 --- a/src/nut_orgnc2.f90 +++ b/src/nut_orgnc2.f90 @@ -60,8 +60,8 @@ subroutine nut_orgnc2 latc_clyr = 0. perc_clyr = 0. - wt1 = 0. !! conversion factor - er = 0. !! enrichment ratio + wt1 = 0. !! conversion factor + er = 0. !! enrichment ratio !! HRU calculations c_ly1 = rsd1(j)%tot_str%n + rsd1(j)%tot_meta%n + soil1(j)%hp(1)%n + soil1(j)%hs(1)%n !wt = sol_bd(1,j) * sol_z(1,j) * 10. (tons/ha) @@ -79,17 +79,17 @@ subroutine nut_orgnc2 !! HRU calculations sedorgn(j) = .001 * conc * sedyld(j) / hru(j)%area_ha - !! update soil nitrogen pools only for HRU calculations + !! update soil nitrogen pools only for HRU calculations if (xx > 1.e-6) then xx1 = (1. - sedorgn(j) / xx) !!add by zhang to update soil nitrogen pools - rsd1(j)%tot_str%n = rsd1(j)%tot_str%n * xx1 - rsd1(j)%tot_meta%n = rsd1(j)%tot_meta%n * xx1 - soil1(j)%hp(1)%n = soil1(j)%hp(1)%n * xx1 - soil1(j)%hs(1)%n = soil1(j)%hs(1)%n * xx1 - !sol_BMN(1,j) = sol_BMN(1,j) * xx1 + rsd1(j)%tot_str%n = rsd1(j)%tot_str%n * xx1 + rsd1(j)%tot_meta%n = rsd1(j)%tot_meta%n * xx1 + soil1(j)%hp(1)%n = soil1(j)%hp(1)%n * xx1 + soil1(j)%hs(1)%n = soil1(j)%hs(1)%n * xx1 + !sol_BMN(1,j) = sol_BMN(1,j) * xx1 end if !return @@ -111,10 +111,10 @@ subroutine nut_orgnc2 ! Not sure whether should consider enrichment ratio or not! YEW = MIN((sedyld(j)/hru(j)%area_ha+YW/hru(j)%area_ha)/(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 + !YEW=MIN(ER*(YSD(NDRV)+YW)/WT(LD1),.9) + !ER enrichment ratio + !YSD water erosion + !YW wind erosion YOC=YEW*TOT soil1(j)%hs(1)%c = soil1(j)%hs(1)%c * X1 soil1(j)%hp(1)%c = soil1(j)%hp(1)%c * X1 @@ -138,7 +138,7 @@ subroutine nut_orgnc2 XX=X1+DK !V=QD+Y4 V = surfq(j) + soil(j)%ly(1)%prk + soil(j)%ly(1)%flat - !QD surface runoff + !QD surface runoff X3=0. IF(V>1.E-10)THEN X3 = soil1(j)%microb(1)%c * (1.-EXP(-V/XX)) !loss of biomass C diff --git a/src/nut_pminrl2.f90 b/src/nut_pminrl2.f90 index 2ec1458..1e188c8 100644 --- a/src/nut_pminrl2.f90 +++ b/src/nut_pminrl2.f90 @@ -26,14 +26,14 @@ subroutine nut_pminrl2 ! |mineral to the stable mineral pool in the soil layer real :: wetness = 0. ! | real :: base = 0. ! | - real :: vara = 0. ! |Intermediate Variable - real :: varb = 0. ! |Intermediate Variable - real :: varc = 0. ! |Intermediate Variable + real :: vara = 0. ! |Intermediate Variable + real :: varb = 0. ! |Intermediate Variable + real :: varc = 0. ! |Intermediate Variable real :: as_p_coeff = 0. ! | - real :: solp = 0. !mg/kg |Solution pool phosphorous content - real :: actpp = 0. !mg/kg |Active pool phosphorous content - real :: stap = 0. !mg/kg |Stable pool phosphorous content - real :: arate = 0. ! |Intermediate Variable + real :: solp = 0. !mg/kg |Solution pool phosphorous content + real :: actpp = 0. !mg/kg |Active pool phosphorous content + real :: stap = 0. !mg/kg |Stable pool phosphorous content + real :: arate = 0. ! |Intermediate Variable real :: ssp = 0. ! | real :: psp = 0. ! | @@ -42,126 +42,126 @@ subroutine nut_pminrl2 hnb_d(j)%lab_min_p = 0. hnb_d(j)%act_sta_p = 0. do l = 1, soil(j)%nly !! loop through soil layers in this HRU - !! make sure that no zero or negative pool values come in - if (soil1(j)%mp(l)%lab <= 1.e-6) soil1(j)%mp(l)%lab = 1.e-6 - if (soil1(j)%mp(l)%act <= 1.e-6) soil1(j)%mp(l)%act = 1.e-6 + !! make sure that no zero or negative pool values come in + if (soil1(j)%mp(l)%lab <= 1.e-6) soil1(j)%mp(l)%lab = 1.e-6 + if (soil1(j)%mp(l)%act <= 1.e-6) soil1(j)%mp(l)%act = 1.e-6 if (soil1(j)%mp(l)%sta <= 1.e-6) soil1(j)%mp(l)%sta = 1.e-6 !! Convert kg/ha to ppm so that it is more meaningful to compare between soil layers - solp = soil1(j)%mp(l)%lab / soil(j)%phys(l)%conv_wt - actpp = soil1(j)%mp(l)%act / soil(j)%phys(l)%conv_wt - stap = soil1(j)%mp(l)%sta / soil(j)%phys(l)%conv_wt - -!! ***************Soluble - Active Transformations*************** - - !! Dynamic PSP Ratio - !!PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43 - if (soil(j)%phys(l)%clay > 0.) then - psp = -0.045 * log(soil(j)%phys(l)%clay)+ (0.001 * solp) - psp = psp - (0.035 * soil1(j)%cbn(l)) + 0.43 - else - psp = 0.4 - end if - !! Limit PSP range - if (psp < .1) psp = 0.1 ! limits on PSP - if (psp > 0.7) psp = 0.7 + solp = soil1(j)%mp(l)%lab / soil(j)%phys(l)%conv_wt + actpp = soil1(j)%mp(l)%act / soil(j)%phys(l)%conv_wt + stap = soil1(j)%mp(l)%sta / soil(j)%phys(l)%conv_wt + +!! ***************Soluble - Active Transformations*************** + + !! Dynamic PSP Ratio + !!PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43 + if (soil(j)%phys(l)%clay > 0.) then + psp = -0.045 * log(soil(j)%phys(l)%clay)+ (0.001 * solp) + psp = psp - (0.035 * soil1(j)%cbn(l)) + 0.43 + else + psp = 0.4 + end if + !! Limit PSP range + if (psp < .1) psp = 0.1 ! limits on PSP + if (psp > 0.7) psp = 0.7 !! Calculate smoothed PSP average - if (soil(j)%ly(l)%psp_store > 0.) then - psp = (soil(j)%ly(l)%psp_store * 29. + psp * 1.) / 30. - end if + if (soil(j)%ly(l)%psp_store > 0.) then + psp = (soil(j)%ly(l)%psp_store * 29. + psp * 1.) / 30. + end if !! Store PSP for tomrrows smoothing calculation - soil(j)%ly(l)%psp_store = psp + soil(j)%ly(l)%psp_store = psp !!***************Dynamic Active/Soluble Transformation Coeff****************** - !! on day 1 just set to a value of zero + !! on day 1 just set to a value of zero if ((time%day == 1) .and. (time%yrs == 1)) then soil(j)%ly(l)%a_days = 0 !! days since P Application soil(j)%ly(l)%b_days = 0 !! days since P deficit - end if + end if !! Calculate P balance rto = psp / (1. - psp) rmp1 = soil1(j)%mp(l)%lab - soil1(j)%mp(l)%act * rto !! P imbalance - !! Move P between the soluble and active pools based on Vadas et al., 2006 - if (rmp1 >= 0.) then !! Net movement from soluble to active - rmp1 = Max(rmp1, (-1 * soil1(j)%mp(l)%lab)) - !! Calculate Dynamic Coefficant + !! Move P between the soluble and active pools based on Vadas et al., 2006 + if (rmp1 >= 0.) then !! Net movement from soluble to active + rmp1 = Max(rmp1, (-1 * soil1(j)%mp(l)%lab)) + !! Calculate Dynamic Coefficant vara = 0.918 * (exp(-4.603 * psp)) - varb = (-0.238 * ALOG(vara)) - 1.126 - if (soil(j)%ly(l)%a_days >0) then - arate = vara * (soil(j)%ly(l)%a_days ** varb) - else - arate = vara * (1) ** varb - end if - !! limit rate coeff from 0.05 to .5 helps on day 1 when a_days is zero - if (arate > 0.5) arate = 0.5 - if (arate < 0.1) arate = 0.1 - rmp1 = arate * rmp1 - soil(j)%ly(l)%a_days = soil(j)%ly(l)%a_days + 1 !! add a day to the imbalance counter - soil(j)%ly(l)%b_days = 0 + varb = (-0.238 * ALOG(vara)) - 1.126 + if (soil(j)%ly(l)%a_days >0) then + arate = vara * (soil(j)%ly(l)%a_days ** varb) + else + arate = vara * (1) ** varb + end if + !! limit rate coeff from 0.05 to .5 helps on day 1 when a_days is zero + if (arate > 0.5) arate = 0.5 + if (arate < 0.1) arate = 0.1 + rmp1 = arate * rmp1 + soil(j)%ly(l)%a_days = soil(j)%ly(l)%a_days + 1 !! add a day to the imbalance counter + soil(j)%ly(l)%b_days = 0 end if - if (rmp1 < 0.) then !! Net movement from Active to Soluble - rmp1 = Min(rmp1, soil1(j)%mp(l)%act) - !! Calculate Dynamic Coefficant - base = (-1.08 * psp) + 0.79 - varc = base * (exp (-0.29)) - !! limit varc from 0.1 to 1 - if (varc > 1.0) varc = 1.0 - if (varc < 0.1) varc = 0.1 + if (rmp1 < 0.) then !! Net movement from Active to Soluble + rmp1 = Min(rmp1, soil1(j)%mp(l)%act) + !! Calculate Dynamic Coefficant + base = (-1.08 * psp) + 0.79 + varc = base * (exp (-0.29)) + !! limit varc from 0.1 to 1 + if (varc > 1.0) varc = 1.0 + if (varc < 0.1) varc = 0.1 rmp1 = rmp1 * varc - soil(j)%ly(l)%a_days = 0 - soil(j)%ly(l)%b_days = soil(j)%ly(l)%b_days + 1 !! add a day to the imbalance counter + soil(j)%ly(l)%a_days = 0 + soil(j)%ly(l)%b_days = soil(j)%ly(l)%b_days + 1 !! add a day to the imbalance counter End if !!*************** Active - Stable Transformations ****************** !! Estimate active stable transformation rate coeff - !! original value was .0006 - !! based on linear regression rate coeff = 0.005 @ 0% CaCo3 0.05 @ 20% CaCo3 - as_p_coeff = 0.0023 * soil(j)%ly(l)%cal + 0.005 + !! original value was .0006 + !! based on linear regression rate coeff = 0.005 @ 0% CaCo3 0.05 @ 20% CaCo3 + as_p_coeff = 0.0023 * soil(j)%ly(l)%cal + 0.005 if (as_p_coeff > 0.05) as_p_coeff = 0.05 if (as_p_coeff < 0.002) as_p_coeff = 0.002 !! Estimate active/stable pool ratio !! Generated from sharpley 2003 - ssp = 25.044 * (actpp + (actpp * rto))** (-0.3833) - ! limit ssp to range in measured data - if (ssp > 10.) ssp = 10. - if (ssp < 0.7) ssp = 0.7 + ssp = 25.044 * (actpp + (actpp * rto))** (-0.3833) + ! limit ssp to range in measured data + if (ssp > 10.) ssp = 10. + if (ssp < 0.7) ssp = 0.7 - ! Smooth ssp, no rapid changes - if (soil(j)%ly(l)%ssp_store > 0.) then - ssp = (ssp + soil(j)%ly(l)%ssp_store * 99.)/100. - end if + ! Smooth ssp, no rapid changes + if (soil(j)%ly(l)%ssp_store > 0.) then + ssp = (ssp + soil(j)%ly(l)%ssp_store * 99.)/100. + end if roc = ssp * (soil1(j)%mp(l)%act + soil1(j)%mp(l)%act * rto) - roc = roc - soil1(j)%mp(l)%sta - roc = as_p_coeff * roc - !! Store todays ssp for tomarrows calculation - soil(j)%ly(l)%ssp_store = ssp + roc = roc - soil1(j)%mp(l)%sta + roc = as_p_coeff * roc + !! Store todays ssp for tomarrows calculation + soil(j)%ly(l)%ssp_store = ssp !! **************** Account for Soil Water content, do not allow movement in dry soil************ wetness = (soil(j)%phys(l)%st/soil(j)%phys(l)%fc) !! range from 0-1 1 = field cap - if (wetness >1.) wetness = 1. - if (wetness <0.25) wetness = 0.25 - rmp1 = rmp1 * wetness - roc = roc * wetness - + if (wetness >1.) wetness = 1. + if (wetness <0.25) wetness = 0.25 + rmp1 = rmp1 * wetness + roc = roc * wetness + !! If total P is greater than 10,000 mg/kg do not allow transformations at all - If ((solp + actpp + stap) < 10000.) then - !! Allow P Transformations - soil1(j)%mp(l)%sta = soil1(j)%mp(l)%sta + roc - if (soil1(j)%mp(l)%sta < 0.) soil1(j)%mp(l)%sta = 0. - soil1(j)%mp(l)%act = soil1(j)%mp(l)%act - roc + rmp1 - if (soil1(j)%mp(l)%act < 0.) soil1(j)%mp(l)%act = 0. - soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab - rmp1 - if (soil1(j)%mp(l)%lab < 0.) soil1(j)%mp(l)%lab = 0. - end if + If ((solp + actpp + stap) < 10000.) then + !! Allow P Transformations + soil1(j)%mp(l)%sta = soil1(j)%mp(l)%sta + roc + if (soil1(j)%mp(l)%sta < 0.) soil1(j)%mp(l)%sta = 0. + soil1(j)%mp(l)%act = soil1(j)%mp(l)%act - roc + rmp1 + if (soil1(j)%mp(l)%act < 0.) soil1(j)%mp(l)%act = 0. + soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab - rmp1 + if (soil1(j)%mp(l)%lab < 0.) soil1(j)%mp(l)%lab = 0. + end if !! Add water soluble P pool assume 1:5 ratio based on sharpley 2005 et al - soil(j)%ly(l)%watp = soil1(j)%mp(l)%lab / 5. + soil(j)%ly(l)%watp = soil1(j)%mp(l)%lab / 5. hnb_d(j)%lab_min_p = hnb_d(j)%lab_min_p + rmp1 hnb_d(j)%act_sta_p = hnb_d(j)%act_sta_p + roc diff --git a/src/nut_solp.f90 b/src/nut_solp.f90 index 8af6668..2eceebe 100644 --- a/src/nut_solp.f90 +++ b/src/nut_solp.f90 @@ -34,7 +34,6 @@ subroutine nut_solp real :: plch = 0. !kg P/ha |amount of P leached from soil layer integer :: ly = 0 !none - real :: tmp_calc = 0. j = ihru @@ -65,14 +64,11 @@ subroutine nut_solp !! compute soluble P leaching do ly = 1, soil(j)%nly vap = 0. - if (ly /= i_sep(j)) then + if (ly /= i_sep(j)) then vap = -soil(j)%ly(ly)%prk / (.01 * soil(j)%phys(ly)%st + .1 * bsn_prm%pperco * soil(j)%phys(ly)%bd) - if (vap < -80.0) then ! This check was added to prevent gfortran aborting on the Exp(ww) function below. - vap = -80 - endif plch = .001 * soil1(j)%mp(ly)%lab * (1. - Exp(vap)) plch = Min(plch, soil1(j)%mp(ly)%lab) - soil1(j)%mp(ly)%lab = soil1(j)%mp(ly)%lab - plch + soil1(j)%mp(ly)%lab = soil1(j)%mp(ly)%lab - plch if (ly == soil(j)%nly) then !! leach p from bottom layer hls_d(j)%lchlabp = plch diff --git a/src/object_read_output.f90 b/src/object_read_output.f90 index 54a4892..5430b30 100644 --- a/src/object_read_output.f90 +++ b/src/object_read_output.f90 @@ -86,15 +86,15 @@ subroutine object_read_output ob_out(i)%hydno = 4 case ("til") !tile ob_out(i)%hydno = 5 - case ("sol") !soil moisture by layer + case ("sol_water") !soil moisture by layer ob_out(i)%hydno = 6 - case ("soln") !soil n and p by layer + case ("solnut_ly") !soil n and p by layer ob_out(i)%hydno = 7 - case ("solpn") !soil n and p for profile + case ("solnut_pr") !soil n and p for profile ob_out(i)%hydno = 8 - case ("plt") !plants status + case ("plant") !plants status ob_out(i)%hydno = 9 - case ("ch_fp") !channel and flood plain water balance + case ("cha_fp") !channel and flood plain water balance ob_out(i)%hydno = 10 end select iunit = ob_out(i)%unitno diff --git a/src/organic_mineral_mass_module.f90 b/src/organic_mineral_mass_module.f90 index 9be7ae4..1e3e6a4 100644 --- a/src/organic_mineral_mass_module.f90 +++ b/src/organic_mineral_mass_module.f90 @@ -39,6 +39,7 @@ module organic_mineral_mass_module character (len=16) :: name = "" real :: tot_mn = 0. ! |total mineral n pool (no3+nh4) in soil profile real :: tot_mp = 0. ! |mineral p pool (wsol+lab+act+sta) in soil profile + real :: salt = 0. ! |total salt amount (kg/ha) in soil profile type (organic_mass) :: tot_org ! |total organics in soil profile real, dimension(:), allocatable :: sw !mm |soil water dimensioned by layer real, dimension(:), allocatable :: cbn !% |percent carbon @@ -93,7 +94,7 @@ module organic_mineral_mass_module type (organic_mass), dimension(:), allocatable :: tot ! |total mass surface residue litter pool-dimensioned by plant type (organic_mass), dimension(:), allocatable :: meta ! |metabolic litter pool-dimensioned by plant type (organic_mass), dimension(:), allocatable :: str ! |structural litter pool-dimensioned by plant - type (organic_mass), dimension(:), allocatable :: lignin ! |lignin pool-dimensioned by plant + type (organic_mass), dimension(:), allocatable :: lignin ! |lignin pool-dimensioned by plant type (organic_mass) :: tot_com !kg/ha |total type (organic_mass) :: tot_meta ! | type (organic_mass) :: tot_str ! | diff --git a/src/orgncswat2.f90 b/src/orgncswat2.f90 index c4acf6d..3047430 100644 --- a/src/orgncswat2.f90 +++ b/src/orgncswat2.f90 @@ -59,8 +59,8 @@ subroutine orgncswat2 perc_clyr = 0. xx = 0. - wt1 = 0. !! conversion factor - er = 0. !! enrichment ratio + wt1 = 0. !! conversion factor + er = 0. !! enrichment ratio !! HRU calculations xx = rsd1(j)%tot_str%n + rsd1(j)%tot_meta%n + soil1(j)%hsta(1)%n + soil1(j)%hact(1)%n !wt = sol_bd(1,j) * sol_z(1,j) * 10. (tons/ha) @@ -78,17 +78,17 @@ subroutine orgncswat2 !! HRU calculations sedorgn(j) = .001 * conc * sedyld(j) / hru(j)%area_ha - !! update soil nitrogen pools only for HRU calculations + !! update soil nitrogen pools only for HRU calculations if (xx > 1.e-6) then xx1 = (1. - sedorgn(j) / xx) !!add by zhang to update soil nitrogen pools - rsd1(j)%str%n = rsd1(j)%str%n * xx1 - rsd1(j)%meta%n = rsd1(j)%meta%n * xx1 - soil1(j)%hsta(1)%n = soil1(j)%hsta(1)%n * xx1 - soil1(j)%hact(1)%n = soil1(j)%hact(1)%n * xx1 - !sol_BMN(1,j) = sol_BMN(1,j) * xx1 + rsd1(j)%str%n = rsd1(j)%str%n * xx1 + rsd1(j)%meta%n = rsd1(j)%meta%n * xx1 + soil1(j)%hsta(1)%n = soil1(j)%hsta(1)%n * xx1 + soil1(j)%hact(1)%n = soil1(j)%hact(1)%n * xx1 + !sol_BMN(1,j) = sol_BMN(1,j) * xx1 end if !return @@ -110,10 +110,10 @@ subroutine orgncswat2 ! Not sure whether should consider enrichment ratio or not! YEW = MIN((sedyld(j)/hru(j)%area_ha+YW/hru(j)%area_ha)/(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 + !YEW=MIN(ER*(YSD(NDRV)+YW)/WT(LD1),.9) + !ER enrichment ratio + !YSD water erosion + !YW wind erosion YOC=YEW*TOT soil1(j)%hact(1)%c = soil1(j)%hact(1)%c * X1 soil1(j)%hsta(1)%c = soil1(j)%hsta(1)%c * X1 @@ -139,7 +139,7 @@ subroutine orgncswat2 XX=X1+DK !V=QD+Y4 V = surfq(j) + soil(j)%ly(k)%prk + soil(j)%ly(1)%flat - !QD surface runoff + !QD surface runoff X3=0. IF(V>1.E-10)THEN X3 = soil1(j)%microb(1)%c * (1.-EXP(-V/XX)) !loss of biomass C diff --git a/src/output_landscape_init.f90 b/src/output_landscape_init.f90 index 2b22c1f..ab2c495 100644 --- a/src/output_landscape_init.f90 +++ b/src/output_landscape_init.f90 @@ -477,8 +477,8 @@ subroutine output_landscape_init end if endif - open (4561,file = "hru_resc_stat.txt", recl = 1500) if (pco%nb_hru%a == "y") then + open (4561,file = "hru_resc_stat.txt", recl = 1500) write (4561,*) bsn%name, prog write (4561,*) resc_hdr write (4561,*) resc_hdr_units @@ -1423,7 +1423,8 @@ subroutine output_landscape_init !! headers for annual crop yields if (pco%crop_yld == "a" .or. pco%crop_yld == "b") then open (4008,file="crop_yld_aa.txt", recl = 1500) - write (4008,*) bsn%name, prog + write (4008,*) bsn%name + write (4008,*) prog write (4008,1000) write (9000,*) "CROP crop_yld_aa.txt" if (pco%csvout == "y") then diff --git a/src/output_landscape_module.f90 b/src/output_landscape_module.f90 index cbbcaf4..10fc2a6 100644 --- a/src/output_landscape_module.f90 +++ b/src/output_landscape_module.f90 @@ -39,12 +39,12 @@ module output_landscape_module real :: satex = 0. !mm H2O |saturation excess flow developed from high water table !rtb gwflow real :: satex_chan = 0. !mm H2O |saturation excess flow reaching main channel !rtb gwflow real :: delsw = 0. !mm H2O |change in soil water volume !rtb gwflow - real :: lagsurf = 0. !mm H2O |surface runoff in transit to channel - real :: laglatq = 0. !mm H2O |lateral flow in transit to channel - real :: lagsatex = 0. !mm H2O |saturation excess flow in transit to channel - real :: wet_evap = 0. !mm H2O |evaporation from wetland surface - real :: wet_out = 0. !mm H2O |outflow (spill) from wetland - real :: wet_stor = 0. !mm H2O |volume stored in wetland at end of time period + real :: lagsurf = 0. !mm H2O |surface runoff in transit to channel + real :: laglatq = 0. !mm H2O |lateral flow in transit to channel + real :: lagsatex = 0. !mm H2O |saturation excess flow in transit to channel + real :: wet_evap = 0. !mm H2O |evaporation from wetland surface + real :: wet_out = 0. !mm H2O |outflow (spill) from wetland + real :: wet_stor = 0. !mm H2O |volume stored in wetland at end of time period end type output_waterbal type (output_waterbal), pointer :: h @@ -292,15 +292,15 @@ module output_landscape_module character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" character (len=8) :: isd = " unit" - character (len=8) :: id = " gis_id" - character (len=16) :: name = " name " + character (len=8) :: id = " gis_id" + character (len=16) :: name = " name " character (len=14) :: precip = " precip" character (len=12) :: snofall = " snofall" - character (len=12) :: snomlt = " snomlt" - character (len=12) :: surq_gen = " surq_gen" - character (len=12) :: latq = " latq" + character (len=12) :: snomlt = " snomlt" + character (len=12) :: surq_gen = " surq_gen" + character (len=12) :: latq = " latq" character (len=12) :: wateryld = " wateryld" - character (len=12) :: perc = " perc" + character (len=12) :: perc = " perc" character (len=12) :: et = " et" character (len=12) :: ecanopy = " ecanopy" character (len=12) :: eplant = " eplant" @@ -313,7 +313,7 @@ module output_landscape_module character (len=12) :: sw_300 = " sw_300" character (len=12) :: sno_init = " sno_init" character (len=12) :: sno_final = " sno_final" - character (len=12) :: snopack = " snopack" + character (len=12) :: snopack = " snopack" character (len=12) :: pet = " pet" character (len=12) :: qtile = " qtile" character (len=12) :: irr = " irr" @@ -336,6 +336,8 @@ module output_landscape_module character (len=12) :: wet_evap = " wet_evap" character (len=12) :: wet_oflo = " wet_oflo" character (len=12) :: wet_stor = " wet_stor" + character (len=16) :: plt_cov = " plant_cov " + character (len=30) :: mgt_ops = " mgt_ops " end type output_waterbal_header type (output_waterbal_header) :: wb_hdr @@ -345,15 +347,15 @@ module output_landscape_module character (len=6) :: day_mo = " " character (len=6) :: yrc = " " character (len=8) :: isd = " " - character (len=8) :: id = " " - character (len=16) :: name = " " + character (len=8) :: id = " " + character (len=16) :: name = " " character (len=14) :: precip = " mm" character (len=12) :: snofall = " mm" - character (len=12) :: snomlt = " mm" - character (len=12) :: surq_gen = " mm" - character (len=12) :: latq = " mm" + character (len=12) :: snomlt = " mm" + character (len=12) :: surq_gen = " mm" + character (len=12) :: latq = " mm" character (len=12) :: wateryld = " mm" - character (len=12) :: perc = " mm" + character (len=12) :: perc = " mm" character (len=12) :: et = " mm" character (len=12) :: ecanopy = " mm" character (len=12) :: eplant = " mm" @@ -366,7 +368,7 @@ module output_landscape_module character (len=12) :: sw_300 = " mm" character (len=12) :: sno_init = " mm" character (len=12) :: sno_final = " mm" - character (len=12) :: snopack = " mm" + character (len=12) :: snopack = " mm" character (len=12) :: pet = " mm" character (len=12) :: qtile = " mm" character (len=12) :: irr = " mm" @@ -397,28 +399,30 @@ module output_landscape_module character (len=6) :: mo = " mon" character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" - character (len=9) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=9) :: isd = " unit " + character (len=8) :: id = " gis_id " + character (len=16) :: name = " name " character(len=12) :: grazn = " grzn " - character(len=12) :: grazp = " grzp " - character(len=12) :: lab_min_p = " lab_min_p " - character(len=12) :: act_sta_p = " act_sta_p " - character(len=17) :: fertn = " fertn " - character(len=17) :: fertp = " fertp " - character(len=17) :: fixn = " fixn " + character(len=12) :: grazp = " grzp " + character(len=12) :: lab_min_p = " lab_min_p " + character(len=12) :: act_sta_p = " act_sta_p " + character(len=17) :: fertn = " fertn " + character(len=17) :: fertp = " fertp " + character(len=17) :: fixn = " fixn " character(len=17) :: denit = " denit " character(len=17) :: act_nit_n = " act_nit_n " character(len=17) :: act_sta_n = " act_sta_n " character(len=17) :: org_lab_p = " org_lab_p " - character(len=17) :: rsd_nitorg_n = " rsd_nitorg_n" - character(len=17) :: rsd_laborg_p = " rsd_laborg_p" - character(len=17) :: no3atmo = " no3atmo " - character(len=17) :: nh4atmo = " nh4atmo " - character(len=17) :: puptake = " puptake " - character(len=17) :: nuptake = " nuptake " - character(len=17) :: gwsoiln = " gwsoiln " - character(len=17) :: gwsoilp = " gwsoilp " + character(len=17) :: rsd_nitorg_n = " rsd_nitorg_n" + character(len=17) :: rsd_laborg_p = " rsd_laborg_p" + character(len=17) :: no3atmo = " no3atmo " + character(len=17) :: nh4atmo = " nh4atmo " + character(len=17) :: nuptake = " nuptake " + character(len=17) :: puptake = " puptake " + character(len=17) :: gwsoiln = " gwsoiln " + character(len=17) :: gwsoilp = " gwsoilp " + character (len=16) :: plt_cov = "plant_cov " + character (len=30) :: mgt_ops = "mgt_ops " end type output_nutbal_header type (output_nutbal_header) :: nb_hdr @@ -427,26 +431,26 @@ module output_landscape_module character (len=6) :: mo = " " character (len=6) :: day_mo = " " character (len=6) :: yrc = " " - character (len=9) :: isd = " " - character (len=8) :: id = " " - character (len=16) :: name = " " + character (len=9) :: isd = " " + character (len=8) :: id = " " + character (len=16) :: name = " " character(len=12) :: grazn = " kgha " - character(len=12) :: grazp = " kgha " - character(len=12) :: lab_min_p = " kgha " - character(len=12) :: act_sta_p = " kgha " - character(len=17) :: fertn = " kgha " - character(len=17) :: fertp = " kgha " - character(len=17) :: fixn = " kgha " - character(len=17) :: denit = " kgha " - character(len=17) :: act_nit_n = " kgha " - character(len=17) :: act_sta_n = " kgha " - character(len=17) :: org_lab_p = " kgha " - character(len=17) :: rsd_nitorg_n = " kgha " - character(len=17) :: rsd_laborg_p = " kgha " - character(len=17) :: no3atmo = " kgha " - character(len=17) :: nh4atmo = " kgha " - character(len=17) :: nuptake = " kgha " - character(len=17) :: puptake = " kgha " + character(len=12) :: grazp = " kgha " + character(len=12) :: lab_min_p = " kgha " + character(len=12) :: act_sta_p = " kgha " + character(len=17) :: fertn = " kgha " + character(len=17) :: fertp = " kgha " + character(len=17) :: fixn = " kgha " + character(len=17) :: denit = " kgha " + character(len=17) :: act_nit_n = " kgha " + character(len=17) :: act_sta_n = " kgha " + character(len=17) :: org_lab_p = " kgha " + character(len=17) :: rsd_nitorg_n = " kgha " + character(len=17) :: rsd_laborg_p = " kgha " + character(len=17) :: no3atmo = " kgha " + character(len=17) :: nh4atmo = " kgha " + character(len=17) :: nuptake = " kgha " + character(len=17) :: puptake = " kgha " character(len=17) :: gwsoiln = " kgha " character(len=17) :: gwsoilp = " kgha " end type output_nutbal_header_units @@ -458,20 +462,22 @@ module output_landscape_module character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" character (len=8) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=8) :: id = " gis_id " + character (len=16) :: name = " name " character (len=12) :: sedyld = " sedyld" character (len=12) :: sedorgn = " sedorgn" character (len=12) :: sedorgp = " sedorgp" character (len=12) :: surqno3 = " surqno3" - character (len=12) :: latno3 = " lat3no3" + character (len=12) :: latno3 = " lat3no3" character (len=12) :: surqsolp = " surqsolp" - character (len=12) :: usle = " usle" + character (len=12) :: usle = " usle" character (len=12) :: sedminp = " sedminp" character (len=12) :: tileno3 = " tileno3" character (len=12) :: lchlabp = " lchlabp" character (len=12) :: tilelabp = " tilelabp" character (len=12) :: satexn = " satexn" + character (len=16) :: plt_cov = " plant_cov " + character (len=30) :: mgt_ops = " mgt_ops " end type output_losses_header type (output_losses_header) :: ls_hdr @@ -481,15 +487,15 @@ module output_landscape_module character (len=6) :: day_mo = " " character (len=6) :: yrc = " " character (len=8) :: isd = " " - character (len=8) :: id = " " - character (len=16) :: name = " " + character (len=8) :: id = " " + character (len=16) :: name = " " character (len=12) :: sedyld = " tha" character (len=12) :: sedorgn = " kgha" character (len=12) :: sedorgp = " kgha" character (len=12) :: surqno3 = " kgha" - character (len=12) :: latno3 = " kgha" + character (len=12) :: latno3 = " kgha" character (len=12) :: surqsolp = " kgha" - character (len=12) :: usle = " tons" + character (len=12) :: usle = " tons" character (len=12) :: sedmin = " kgha" character (len=12) :: tileno3 = " kgha" character (len=12) :: lchlabp = " kgha" @@ -503,17 +509,17 @@ module output_landscape_module character (len=6) :: mo = " mon" character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" - character (len=9) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=9) :: name = " name " - character(len=17) :: lab_min_p = " lab_min_p" + character (len=9) :: isd = " unit " + character (len=8) :: id = " gis_id " + character (len=9) :: name = " name " + character(len=17) :: lab_min_p = " lab_min_p" character(len=17) :: act_sta_p = " act_sta_p" character(len=17) :: act_nit_n = " act_nit_n" character(len=17) :: act_sta_n = " act_sta_n" character(len=17) :: org_lab_p = " org_lab_p" character(len=17) :: rsd_hs_c = " rsd_hs_c" character(len=17) :: rsd_nitorg_n = " rsd_nitrorg_n" - character(len=17) :: rsd_laborg_p = " rsd_laborg_p" + character(len=17) :: rsd_laborg_p = " rsd_laborg_p" end type output_nutcarb_cycling_header type (output_nutcarb_cycling_header) :: nb_hdr1 @@ -522,17 +528,17 @@ module output_landscape_module character (len=6) :: mo = " " character (len=6) :: day_mo = " " character (len=6) :: yrc = " " - character (len=9) :: isd = " " - character (len=8) :: id = " " - character (len=9) :: name = " " + character (len=9) :: isd = " " + character (len=8) :: id = " " + character (len=9) :: name = " " character(len=17) :: lab_min_p = " kgha" - character(len=17) :: act_sta_p = " kgha" - character(len=17) :: act_nit_n = " kgha" - character(len=17) :: act_sta_n = " kgha" - character(len=17) :: org_lab_p = " kgha" - character(len=17) :: rsd_hs_c = " kgha" - character(len=17) :: rsd_nitorg_n = " kgha" - character(len=17) :: rsd_laborg_p = " kgha" + character(len=17) :: act_sta_p = " kgha" + character(len=17) :: act_nit_n = " kgha" + character(len=17) :: act_sta_n = " kgha" + character(len=17) :: org_lab_p = " kgha" + character(len=17) :: rsd_hs_c = " kgha" + character(len=17) :: rsd_nitorg_n = " kgha" + character(len=17) :: rsd_laborg_p = " kgha" end type output_nutbal_header_units1 type (output_nutbal_header_units1) :: nb_hdr_units1 @@ -542,10 +548,10 @@ module output_landscape_module character (len=6) :: mo = " mon" character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" - character (len=9) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=9) :: name = " name " - character(len=17) :: sed_c = " sed_c" + character (len=9) :: isd = " unit " + character (len=8) :: id = " gis_id " + character (len=9) :: name = " name " + character(len=17) :: sed_c = " sed_c" character(len=17) :: surq_c = " surq_c" character(len=17) :: surq_doc = " surq_doc" character(len=17) :: surq_dic = " surq_dic" @@ -553,8 +559,8 @@ module output_landscape_module character(len=17) :: latq_doc = " latq_doc" character(len=17) :: latq_dic = " latq_dic" character(len=17) :: perc_c = " perc_c" - character(len=17) :: perc_doc = " perc_doc" - character(len=17) :: perc_dic = " perc_dic" + character(len=17) :: perc_doc = " perc_doc" + character(len=17) :: perc_dic = " perc_dic" character(len=17) :: npp_c = " npp_c" character(len=17) :: rsd_c = " rsd_c" character(len=17) :: grain_c = " grain_c" @@ -569,16 +575,16 @@ module output_landscape_module character (len=6) :: mo = " " character (len=6) :: day_mo = " " character (len=6) :: yrc = " " - character (len=9) :: isd = " " - character (len=8) :: id = " " - character (len=9) :: name = " " + character (len=9) :: isd = " " + character (len=8) :: id = " " + character (len=9) :: name = " " character(len=17) :: sed_c = " kg C/ha" - character(len=17) :: surq_c = " kg C/ha" - character(len=17) :: surq_doc = " kg C/ha" - character(len=17) :: surq_dic = " kg C/ha" - character(len=17) :: latq_c = " kg C/ha" - character(len=17) :: latq_doc = " kg C/ha" - character(len=17) :: latq_dic = " kg C/ha" + character(len=17) :: surq_c = " kg C/ha" + character(len=17) :: surq_doc = " kg C/ha" + character(len=17) :: surq_dic = " kg C/ha" + character(len=17) :: latq_c = " kg C/ha" + character(len=17) :: latq_doc = " kg C/ha" + character(len=17) :: latq_dic = " kg C/ha" character(len=17) :: perc_c = " kg C/ha" character(len=17) :: perc_doc = " kg C/ha" character(len=17) :: perc_dic = " kg C/ha" @@ -597,20 +603,20 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " character (len=16) :: name = " name " character(len=15) :: sed_c = " sed_c" - character(len=15) :: surq_c = " surq_c" - character(len=15) :: surq_doc = " surq_doc" + character(len=15) :: surq_c = " surq_c" + character(len=15) :: surq_doc = " surq_doc" character(len=15) :: surq_dic = " surq_dic" - character(len=15) :: latq_c = " latq_c" + character(len=15) :: latq_c = " latq_c" character(len=15) :: latq_doc = " latq_doc" character(len=15) :: latq_dic = " latq_dic" character(len=15) :: perc_c = " perc_c" - character(len=15) :: perc_doc = " perc_doc" - character(len=15) :: perc_dic = " perc_dic" + character(len=15) :: perc_doc = " perc_doc" + character(len=15) :: perc_dic = " perc_dic" character(len=15) :: res_decay = " res_decay" character(len=15) :: man_app_c = " man_app_c" character(len=15) :: man_graze_c = " man_graze_c" @@ -623,17 +629,17 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: sed_c = " kg C/ha" - character(len=15) :: surq_c = " kg C/ha" - character(len=15) :: surq_doc = " kg C/ha" - character(len=15) :: surq_dic = " kg C/ha" - character(len=15) :: latq_c = " kg C/ha" - character(len=15) :: latq_doc = " kg C/ha" - character(len=15) :: latq_dic = " kg C/ha" + character(len=15) :: surq_c = " kg C/ha" + character(len=15) :: surq_doc = " kg C/ha" + character(len=15) :: surq_dic = " kg C/ha" + character(len=15) :: latq_c = " kg C/ha" + character(len=15) :: latq_doc = " kg C/ha" + character(len=15) :: latq_dic = " kg C/ha" character(len=15) :: perc_c = " kg C/ha" character(len=15) :: perc_doc = " kg C/ha" character(len=15) :: perc_dic = " kg C/ha" @@ -653,13 +659,13 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " character (len=16) :: name = " name " character(len=15) :: plant_c = " plant_c" - character(len=15) :: res_decay_c = " res_decay_c" - character(len=15) :: harv_stov_c = " harv_stov_c" + character(len=15) :: res_decay_c = " res_decay_c" + character(len=15) :: harv_stov_c = " harv_stov_c" character(len=15) :: emit_c = " emit_c" end type output_rescarb_header type (output_rescarb_header) :: rescarb_hdr @@ -668,13 +674,13 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: plant_c = " kg C/ha" - character(len=15) :: res_decay_c = " kg C/ha" - character(len=15) :: harv_stov_c = " kg C/ha" + character(len=15) :: res_decay_c = " kg C/ha" + character(len=15) :: harv_stov_c = " kg C/ha" character(len=15) :: emit_c = " kg C/ha" end type output_rescarb_header_units type (output_rescarb_header_units) :: rescarb_hdr_units @@ -687,13 +693,13 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " + character (len=16) :: name = " name " character(len=15) :: npp_c = " npp_c" - character(len=15) :: harv_c = " harv_c" - character(len=15) :: drop_c = " drop_c" + character(len=15) :: harv_c = " harv_c" + character(len=15) :: drop_c = " drop_c" character(len=15) :: grazeat_c = " grazeat_c" character(len=15) :: emit_c = " emit_c" end type output_plcarb_header @@ -703,14 +709,14 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: npp_c = " kg C/ha" - character(len=15) :: harv_c = " kg C/ha" - character(len=15) :: drop_c = " kg C/ha" - character(len=15) :: grazeat_c = " kg C/ha" + character(len=15) :: harv_c = " kg C/ha" + character(len=15) :: drop_c = " kg C/ha" + character(len=15) :: grazeat_c = " kg C/ha" character(len=15) :: emit_c = " kg C/ha" end type output_plcarb_header_units type (output_plcarb_header_units) :: plcarb_hdr_units @@ -723,18 +729,18 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " + character (len=16) :: name = " name " character(len=15) :: meta_micr = " meta_micr" - character(len=15) :: str_micr = " str_micr" - character(len=15) :: str_hs = " str_hs" + character(len=15) :: str_micr = " str_micr" + character(len=15) :: str_hs = " str_hs" character(len=15) :: co2_meta = " co2_meta" character(len=15) :: co2_str = " co2_str" character(len=15) :: micr_hs = " micr_hs" character(len=15) :: micr_hp = " micr_hp" - character(len=15) :: hs_micr = " hs_micr" + character(len=15) :: hs_micr = " hs_micr" character(len=15) :: hs_hp = " hs_hp" character(len=15) :: hp_micr = " hp_micr" character(len=15) :: co2_micr = " co2_micr" @@ -747,13 +753,13 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: meta_micr = " kg C/ha" - character(len=15) :: str_micr = " kg C/ha" - character(len=15) :: str_hs = " kg C/ha" + character(len=15) :: str_micr = " kg C/ha" + character(len=15) :: str_hs = " kg C/ha" character(len=15) :: co2_meta = " kg C/ha" character(len=15) :: co2_str = " kg C/ha" character(len=15) :: micr_hs = " kg C/ha" @@ -763,7 +769,7 @@ module output_landscape_module character(len=15) :: hp_micr = " kg C/ha" character(len=15) :: co2_micr = " kg C/ha" character(len=15) :: co2_hs = " kg C/ha" - character(len=15) :: co2_hp = " kg C/ha" + character(len=15) :: co2_hp = " kg C/ha" end type output_hscf_header_units type (output_hscf_header_units) :: hscf_hdr_units @@ -775,13 +781,13 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " + character (len=16) :: name = " name " character(len=15) :: tot_c = " meta_micr" - character(len=15) :: ab_gr_c = " ab_gr_c" - character(len=15) :: leaf_c = " leaf_c" + character(len=15) :: ab_gr_c = " ab_gr_c" + character(len=15) :: leaf_c = " leaf_c" character(len=15) :: stem_c = " stem_c" character(len=15) :: seed_c = " seed_c" character(len=15) :: root_c = " root_c" @@ -792,13 +798,13 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: tot_c = " kg/ha" - character(len=15) :: ab_gr_c = " kg/ha" - character(len=15) :: leaf_c = " kg/ha" + character(len=15) :: ab_gr_c = " kg/ha" + character(len=15) :: leaf_c = " kg/ha" character(len=15) :: stem_c = " kg/ha" character(len=15) :: seed_c = " kg/ha" character(len=15) :: root_c = " kg/ha" @@ -813,13 +819,13 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " + character (len=16) :: name = " name " character(len=15) :: tot_c = " tot_c" - character(len=15) :: meta_c = " meta_c" - character(len=15) :: str_c = " str_c" + character(len=15) :: meta_c = " meta_c" + character(len=15) :: str_c = " str_c" character(len=15) :: lig_c = " lig_c" end type output_resc_header @@ -829,13 +835,13 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: tot_c = " kg/ha" - character(len=15) :: meta_c = " kg/ha" - character(len=15) :: str_c = " kg/ha" + character(len=15) :: meta_c = " kg/ha" + character(len=15) :: str_c = " kg/ha" character(len=15) :: lig_c = " kg/ha" end type output_resc_header_units type (output_resc_header_units) :: resc_hdr_units @@ -848,17 +854,17 @@ module output_landscape_module character (len=11) :: day = " jday" character (len=11) :: mo = " mon" character (len=11) :: day_mo = " day" - character (len=11) :: yrc = " yr" - character (len=16) :: isd = " unit" - character (len=21) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=11) :: yrc = " yr" + character (len=16) :: isd = " unit" + character (len=21) :: id = " gis_id " + character (len=16) :: name = " name " character(len=15) :: tot_org_c = " tot_org_c" - character(len=15) :: str_c = " str_c" - character(len=15) :: lig_c = " lib_c" + character(len=15) :: str_c = " str_c" + character(len=15) :: lig_c = " lib_c" character(len=15) :: meta_c = " meta_c" character(len=15) :: man_c = " man_c" - character(len=15) :: humus_low_c = " humus_low_c" - character(len=15) :: humus_pass_c = " humus_pass_c" + character(len=15) :: humus_low_c = " humus_low_c" + character(len=15) :: humus_pass_c = " humus_pass_c" character(len=15) :: microb_c = " microb_c" end type output_soilc_header type (output_soilc_header) :: soilc_hdr @@ -867,17 +873,17 @@ module output_landscape_module character (len=11) :: day = " " character (len=11) :: mo = " " character (len=11) :: day_mo = " " - character (len=11) :: yrc = " " - character (len=16) :: isd = " " - character (len=21) :: id = " " - character (len=16) :: name = " " + character (len=11) :: yrc = " " + character (len=16) :: isd = " " + character (len=21) :: id = " " + character (len=16) :: name = " " character(len=15) :: tot_org_c = " kg/ha" - character(len=15) :: str_c = " kg/ha" - character(len=15) :: lig_c = " kg/ha" + character(len=15) :: str_c = " kg/ha" + character(len=15) :: lig_c = " kg/ha" character(len=15) :: meta_c = " kg/ha" character(len=15) :: man_c = " kg/ha" - character(len=15) :: humus_low_c = " kg/ha" - character(len=15) :: humus_pass_c = " kg/ha" + character(len=15) :: humus_low_c = " kg/ha" + character(len=15) :: humus_pass_c = " kg/ha" character(len=15) :: microb_c = " kg/ha" end type output_soilc_header_units type (output_soilc_header_units) :: soilc_hdr_units @@ -888,21 +894,21 @@ module output_landscape_module type output_bsn_carb_header character (len=11) :: day = " jday" - character (len=11) :: yrc = " yr" + character (len=11) :: yrc = " yr" character (len=6) :: blnk = " " character (len=15) :: org_soilc = " org_soilc" - character (len=15) :: org_plc = " org_plc" - character (len=15) :: org_resc = " org_resc" + character (len=15) :: org_plc = " org_plc" + character (len=15) :: org_resc = " org_resc" end type output_bsn_carb_header type (output_bsn_carb_header) :: bsn_carb_hdr type output_bsn_carb_header_units character (len=11) :: day = " " - character (len=11) :: yrc = " " + character (len=11) :: yrc = " " character (len=6) :: blnk = " " character(len=15) :: org_soilc = " kg/ha" - character(len=15) :: org_plc = " kg/ha" - character(len=15) :: org_resc = " kg/ha" + character(len=15) :: org_plc = " kg/ha" + character(len=15) :: org_resc = " kg/ha" end type output_bsn_carb_header_units type (output_bsn_carb_header_units) :: bsn_carb_hdr_units @@ -910,21 +916,21 @@ module output_landscape_module type output_losses_header1 - character (len=6) :: day = " jday" + character (len=5) :: day = " jday" character (len=6) :: mo = " mon" character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" character (len=9) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=9) :: name = " name " + character (len=8) :: id = " gis_id " + character (len=9) :: name = " name " character (len=17) :: sedyld = " sedyld" - character (len=17) :: usle = " usle" - character (len=17) :: sedorgc = " sedorgc" + character (len=17) :: usle = " usle" + character (len=17) :: sedorgc = " sedorgc" character (len=17) :: sedorgn = " sedorgn" character (len=17) :: sedorgp = " sedorgp" character (len=17) :: surqno3 = " surqno3" - character (len=17) :: latno3 = " lat3no3" - character (len=17) :: surqsolp = " surqsolp" + character (len=17) :: latno3 = " lat3no3" + character (len=17) :: surqsolp = " surqsolp" character (len=17) :: sedminp = " sedminp" character (len=17) :: tileno3 = " tileno3" character (len=17) :: no3atmo = " no3atmo" @@ -950,20 +956,20 @@ module output_landscape_module type (output_losses_header1) :: ls_hdr1 type output_losses_header_units1 - character (len=6) :: day = " " + character (len=5) :: day = " " character (len=6) :: mo = " " character (len=6) :: day_mo = " " character (len=6) :: yrc = " " character (len=9) :: isd = " " - character (len=8) :: id = " " - character (len=9) :: name = " " + character (len=8) :: id = " " + character (len=9) :: name = " " character (len=17) :: sedyld = " tons" character (len=17) :: usle = " tha" character (len=17) :: sedorgc = " kgha" character (len=17) :: sedorgn = " kgha" character (len=17) :: sedorgp = " kgha" character (len=17) :: surqno3 = " kgha" - character (len=17) :: latno3 = " kgha" + character (len=17) :: latno3 = " kgha" character (len=17) :: surqsolp = " kgha" character (len=17) :: sedmin = " ----" character (len=17) :: tileno3 = " kgha" @@ -995,8 +1001,8 @@ module output_landscape_module character (len=6) :: day_mo = " day" character (len=6) :: yrc = " yr" character (len=8) :: isd = " unit " - character (len=8) :: id = " gis_id " - character (len=16) :: name = " name " + character (len=8) :: id = " gis_id " + character (len=16) :: name = " name " character (len=13) :: lai = " lai" character (len=12) :: bioms = " bioms" character (len=12) :: yield = " yield" @@ -1021,7 +1027,9 @@ module output_landscape_module character (len=12) :: lai_max = " lai_max" character (len=12) :: bm_max = " bm_max" character (len=12) :: bm_grow = " bm_grow" - character (len=12) :: c_gro = " c_gro" + character (len=12) :: c_gro = " c_gro" + character (len=16) :: plt_cov = " plant_cov " + character (len=30) :: mgt_ops = " mgt_ops " end type output_plantweather_header type (output_plantweather_header) :: pw_hdr @@ -1031,19 +1039,19 @@ module output_landscape_module character (len=6) :: day_mo = " " character (len=6) :: yrc = " " character (len=8) :: isd = " " - character (len=8) :: id = " " - character (len=16) :: name = " " + character (len=8) :: id = " " + character (len=16) :: name = " " character (len=13) :: lai = " m**2/m**2" character (len=12) :: bioms = " kgha" character (len=12) :: yield = " kgha" character (len=12) :: residue = " kgha" character (len=12) :: sol_tmp = " degc" - character (len=12) :: strsw = " ----" - character (len=12) :: strsa = " ----" - character (len=12) :: strstmp = " ----" - character (len=12) :: strsn = " ----" - character (len=12) :: strsp = " ----" - character (len=12) :: strss = " ----" + character (len=12) :: strsw = " ----" + character (len=12) :: strsa = " ----" + character (len=12) :: strstmp = " ----" + character (len=12) :: strsn = " ----" + character (len=12) :: strsp = " ----" + character (len=12) :: strss = " ----" character (len=12) :: nplnt = " kgha" character (len=12) :: percn = " kgha" character (len=12) :: pplnt = " kgha" diff --git a/src/pathogen_init.f90 b/src/pathogen_init.f90 index 4daf628..0e5ac71 100644 --- a/src/pathogen_init.f90 +++ b/src/pathogen_init.f90 @@ -54,11 +54,11 @@ subroutine pathogen_init !! allocate pathogens associated with soil and plant do ly = 1, soil(ihru)%nly allocate (cs_soil(ihru)%ly(ly)%path(mpath), source = 0.) - allocate (cs_pl(ihru)%pl_in(ipl)%pest(mpath), source = 0.) - allocate (cs_pl(ihru)%pl_on(ipl)%pest(mpath), source = 0.) - allocate (cs_pl(ihru)%pl_up(ipl)%pest(mpath), source = 0.) end do do ipl = 1, pcom(ihru)%npl + allocate (cs_pl(ihru)%pl_in(ipl)%path(mpath), source = 0.) + allocate (cs_pl(ihru)%pl_on(ipl)%path(mpath), source = 0.) + allocate (cs_pl(ihru)%pl_up(ipl)%path(mpath), source = 0.) end do allocate (cs_irr(ihru)%path(mpath)) end if diff --git a/src/pesticide_init.f90 b/src/pesticide_init.f90 index a68bd93..b3b2b0a 100644 --- a/src/pesticide_init.f90 +++ b/src/pesticide_init.f90 @@ -40,14 +40,14 @@ subroutine pesticide_init allocate (cs_pl(ihru)%pl_up(npl)) do ly = 1, nly allocate (cs_soil(ihru)%ly(ly)%pest(npmx), source = 0.) - allocate (cs_pl(ihru)%pl_in(ipl)%pest(npmx), source = 0.) - allocate (cs_pl(ihru)%pl_on(ipl)%pest(npmx), source = 0.) - allocate (cs_pl(ihru)%pl_up(ipl)%pest(npmx), source = 0.) cs_soil(ihru)%ly(ly)%pest = 0. end do do ipl = 1, npl + allocate (cs_pl(ihru)%pl_in(ipl)%pest(npmx), source = 0.) cs_pl(ihru)%pl_in(ipl)%pest = 0. + allocate (cs_pl(ihru)%pl_on(ipl)%pest(npmx), source = 0.) cs_pl(ihru)%pl_on(ipl)%pest = 0. + allocate (cs_pl(ihru)%pl_up(ipl)%pest(npmx), source = 0.) cs_pl(ihru)%pl_up(ipl)%pest = 0. end do allocate (cs_irr(ihru)%pest(npmx)) diff --git a/src/pl_burnop.f90 b/src/pl_burnop.f90 index 9ba0008..4ed13dd 100644 --- a/src/pl_burnop.f90 +++ b/src/pl_burnop.f90 @@ -46,7 +46,7 @@ subroutine pl_burnop (jj, iburn) soil1(j)%hact(1)%n = soil1(j)%hact(1)%n * fr_burn soil1(j)%hsta(1)%n = soil1(j)%hsta(1)%n* fr_burn - !!insert new biomss by zhang + !!insert new biomss by zhang !!================================= if (bsn_cc%cswat == 2) then rsd1(j)%tot_meta%m = rsd1(j)%tot_meta%m * fr_burn diff --git a/src/pl_fert.f90 b/src/pl_fert.f90 index d45e53a..f349305 100644 --- a/src/pl_fert.f90 +++ b/src/pl_fert.f90 @@ -81,18 +81,18 @@ subroutine pl_fert (ifrt, frt_kg, fertop) soil1(j)%hsta(l)%p = soil1(j)%hsta(l)%p + (1. - rtof)*xx*frt_kg * & fertdb(ifrt)%forgp end if - if (bsn_cc%cswat == 1) then - soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg * & - fertdb(ifrt)%forgn * 10. - soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg * & - fertdb(ifrt)%forgn - soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg * & - fertdb(ifrt)%forgp - end if + if (bsn_cc%cswat == 1) then + soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg * & + fertdb(ifrt)%forgn * 10. + soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg * & + fertdb(ifrt)%forgn + soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg * & + fertdb(ifrt)%forgp + end if !!By Zhang for C/N cycling !!=========================== - if (bsn_cc%cswat == 2) then + if (bsn_cc%cswat == 2) then soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx * & frt_kg * fertdb(ifrt)%forgp soil1(j)%hsta(l)%p = soil1(j)%hsta(l)%p + (1. - rtof) * xx * & @@ -158,7 +158,7 @@ subroutine pl_fert (ifrt, frt_kg, fertop) !end if - end if + end if !!By Zhang for C/N cycling !!=========================== diff --git a/src/pl_fert_wet.f90 b/src/pl_fert_wet.f90 index 70eeb1b..6730b93 100644 --- a/src/pl_fert_wet.f90 +++ b/src/pl_fert_wet.f90 @@ -67,18 +67,18 @@ subroutine pl_fert_wet (ifrt, frt_kg) wet(j)%sedp = wet(j)%sedp + frt_kg * fertdb(ifrt)%forgp end if - ! if (bsn_cc%cswat == 1) then - ! soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg * & - ! fertdb(ifrt)%forgn * 10. - ! soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg * & - ! fertdb(ifrt)%forgn - ! soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg * & - ! fertdb(ifrt)%forgp - ! end if + ! if (bsn_cc%cswat == 1) then + ! soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg * & + ! fertdb(ifrt)%forgn * 10. + ! soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg * & + ! fertdb(ifrt)%forgn + ! soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg * & + ! fertdb(ifrt)%forgp + ! end if ! ! !!By Zhang for C/N cycling ! !!=========================== - ! if (bsn_cc%cswat == 2) then + ! if (bsn_cc%cswat == 2) then ! soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx * & ! frt_kg * fertdb(ifrt)%forgp ! soil1(j)%hsta(l)%p = soil1(j)%hsta(l)%p + (1. - rtof) * xx * & @@ -144,7 +144,7 @@ subroutine pl_fert_wet (ifrt, frt_kg) ! ! !end if ! - !end if + !end if ! !!By Zhang for C/N cycling ! !!=========================== ! diff --git a/src/pl_grow.f90 b/src/pl_grow.f90 index 246a4fc..c2107de 100644 --- a/src/pl_grow.f90 +++ b/src/pl_grow.f90 @@ -40,7 +40,7 @@ subroutine pl_grow call pl_seed_gro(j) - call pl_partition(j) + call pl_partition(j, 0) end if diff --git a/src/pl_leaf_drop.f90 b/src/pl_leaf_drop.f90 index 0bdd226..ecfcac1 100644 --- a/src/pl_leaf_drop.f90 +++ b/src/pl_leaf_drop.f90 @@ -49,7 +49,7 @@ subroutine pl_leaf_drop (resnew, resnew_n) real :: LSF = 0. !frac |fraction of the litter that is structural real :: LMNF = 0. !kg kg-1 |fraction of metabolic litter that is N real :: LSLF = 0. !kg kg-1 |fraction of structural litter that is lignin - real :: LSNF = 0. !kg kg-1 |fraction of structural litter that is N + real :: LSNF = 0. !kg kg-1 |fraction of structural litter that is N orgc_f = 0. BLG1 = 0. @@ -89,13 +89,13 @@ subroutine pl_leaf_drop (resnew, resnew_n) CLG=BLG3*pcom(j)%plcur(ipl)%phuacc/ (pcom(j)%plcur(ipl)%phuacc + & EXP(BLG1-BLG2*pcom(j)%plcur(ipl)%phuacc)) - sf = 0.05 - sol_min_n = (soil1(j)%mn(1)%no3 + soil1(j)%mn(1)%nh4) + sf = 0.05 + sol_min_n = (soil1(j)%mn(1)%no3 + soil1(j)%mn(1)%nh4) resnew_ne = resnew_n + sf * sol_min_n 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 @@ -103,17 +103,17 @@ subroutine pl_leaf_drop (resnew, resnew_n) if (LMF >0.7) then LMF = 0.7 end if - end if + end if LSF = 1 - LMF - + rsd1(j)%meta%m = rsd1(j)%meta%m + LMF * resnew rsd1(j)%str%m = rsd1(j)%str%m + LSF * resnew LSLF = CLG - + rsd1(j)%tot_str%c = rsd1(j)%tot_str%c + 0.42*LSF * resnew - + rsd1(j)%tot_lignin%c = rsd1(j)%tot_lignin%c + RLR * 0.42 * LSF * resnew rsd1(j)%tot_lignin%c = rsd1(j)%tot_str%c - rsd1(j)%tot_lignin%c @@ -124,7 +124,7 @@ subroutine pl_leaf_drop (resnew, resnew_n) else rsd1(j)%tot_str%n = rsd1(j)%tot_str%n + resnew_ne rsd1(j)%tot_meta%n = rsd1(j)%tot_meta%n + 1.E-25 - end if + end if rsd1(j)%tot_meta%c = rsd1(j)%tot_meta%c + 0.42 * LMF * resnew diff --git a/src/pl_leaf_gro.f90 b/src/pl_leaf_gro.f90 index b6fe069..f1d5928 100644 --- a/src/pl_leaf_gro.f90 +++ b/src/pl_leaf_gro.f90 @@ -78,7 +78,6 @@ subroutine pl_leaf_gro real :: rto = 0. !none |ratio of current years of growth:years to maturity of perennial real :: sumlaiht = 0. ! | integer :: jpl = 0 !none |counter - real :: tmp_calc j = ihru idp = pcom(j)%plcur(ipl)%idplt @@ -89,14 +88,9 @@ subroutine pl_leaf_gro ff = f - pcom(j)%plg(ipl)%laimxfr pcom(j)%plg(ipl)%laimxfr = f - tmp_calc = plcp(idp)%leaf1 - plcp(idp)%leaf2 * pcom(j)%plcur(ipl)%phuacc_p !Changed by fg to prevent underflow in gfortran - if (tmp_calc < -20.) then !Changed by fg to prevent underflow in gfortran - tmp_calc = -20. !Changed by fg to prevent underflow in gfortran - endif - f_p = pcom(j)%plcur(ipl)%phuacc_p / (pcom(j)%plcur(ipl)%phuacc_p + Exp(tmp_calc)) !Changed by fg to prevent underflow in gfortran - !f_p = pcom(j)%plcur(ipl)%phuacc_p / (pcom(j)%plcur(ipl)%phuacc_p + & - ! Exp(plcp(idp)%leaf1 - plcp(idp)%leaf2 * pcom(j)%plcur(ipl)%phuacc_p)) + f_p = pcom(j)%plcur(ipl)%phuacc_p / (pcom(j)%plcur(ipl)%phuacc_p + & + Exp(plcp(idp)%leaf1 - plcp(idp)%leaf2 * pcom(j)%plcur(ipl)%phuacc_p)) !pcom(j)%plg(ipl)%laimxfr_p = amin1 (f_p, pcom(j)%plg(ipl)%laimxfr_p) !ff_p = f_p - pcom(j)%plg(ipl)%laimxfr_p diff --git a/src/pl_leaf_senes.f90 b/src/pl_leaf_senes.f90 index d7e2ed9..495557b 100644 --- a/src/pl_leaf_senes.f90 +++ b/src/pl_leaf_senes.f90 @@ -76,10 +76,11 @@ subroutine pl_leaf_senes end if lai_drop = max (0., lai_drop) lai_drop = amin1 (1., lai_drop) - leaf_drop%m = lai_drop * pl_mass(j)%leaf(ipl)%m - leaf_drop%n = leaf_drop%m * pcom(j)%plm(ipl)%n_fr + !! forest -- total tree n_conc = 1.75%; leaf = 2.25%, falling leaf = 50%*2.25% = 1.12% --> 1.12/1.75 = 0.68 + leaf_drop%m = pcom(j)%plcur(ipl)%leaf_tov * pl_mass(j)%leaf(ipl)%m + leaf_drop%n = 0.68 * leaf_drop%m * pcom(j)%plm(ipl)%n_fr leaf_drop%n = max (0., leaf_drop%n) - leaf_drop%p = leaf_drop%m * pcom(j)%plm(ipl)%p_fr + leaf_drop%p = 0.68 * leaf_drop%m * pcom(j)%plm(ipl)%p_fr leaf_drop%p = max (0., leaf_drop%p) end if end if @@ -109,10 +110,11 @@ subroutine pl_leaf_senes !pcom(j)%plg(ipl)%lai = max (pcom(j)%plg(ipl)%lai, pldb(idp)%alai_min) !! compute leaf biomass drop + !! forest -- total tree n_conc = 1.75%; leaf = 2.25%, falling leaf = 50%*2.25% = 1.12% --> 1.12/1.75 = 0.68 leaf_drop%m = pcom(j)%plcur(ipl)%leaf_tov * pl_mass(j)%leaf(ipl)%m - leaf_drop%n = leaf_drop%m * pcom(j)%plm(ipl)%n_fr + leaf_drop%n = 0.68 * leaf_drop%m * pcom(j)%plm(ipl)%n_fr leaf_drop%n = max (0., leaf_drop%n) - leaf_drop%p = leaf_drop%m * pcom(j)%plm(ipl)%p_fr + leaf_drop%p = 0.68 * leaf_drop%m * pcom(j)%plm(ipl)%p_fr leaf_drop%p = max (0., leaf_drop%p) end if diff --git a/src/pl_partition.f90 b/src/pl_partition.f90 index 76b5c56..434353a 100644 --- a/src/pl_partition.f90 +++ b/src/pl_partition.f90 @@ -1,4 +1,4 @@ - subroutine pl_partition(j) + subroutine pl_partition(j, init) use plant_data_module use basin_module @@ -10,6 +10,7 @@ subroutine pl_partition(j) implicit none integer, intent (in) :: j !none |HRU number + integer, intent (in) :: init !none |init=1 to intialize and transplant; init=0 during simulation integer :: idp = 0 ! | real :: root_frac = 0. !none |root mass fraction real :: ab_gr_frac = 0. !none |above ground mass fraction @@ -20,7 +21,9 @@ subroutine pl_partition(j) real :: n_frac = 0. !none |n fraction in remainder of plant real :: p_left = 0. !none |p left after seed is removed real :: p_frac = 0. !none |p fraction in remainder of plant - real :: m_left = 0. !none |mass left after seed is removed + real :: mass_left = 0. !none |mass left after plant component is removed + real :: mass_act = 0. !none |actual mass in each plant component + real :: mass_opt = 0. !none |optimal mass in each plant component real :: leaf_frac_veg = 0. !none |fraction veg mass (stem+leaf) that is leaf real :: leaf_mass_frac_veg = 0. !none |fraction veg mass (stem+leaf) that is leaf @@ -32,7 +35,7 @@ subroutine pl_partition(j) !! partition leaf and stem (stalk) and seed (grain) mass if (pldb(idp)%typ == "perennial") then - leaf_frac_veg = 0.05 !forest + leaf_frac_veg = 0.02 !forest else leaf_frac_veg = 0.30 !should be plant parm end if @@ -56,11 +59,50 @@ subroutine pl_partition(j) stem_mass_frac = 1. - (leaf_mass_frac_veg + seed_mass_frac) end if + !! check if initializing + if (init == 0) then + !! first maintain root fraction - root mass/total mass + mass_left = pl_mass_up%m + mass_act = pl_mass(j)%root(ipl)%m + mass_opt = root_frac * pl_mass(j)%tot(ipl)%m + if (mass_act > mass_opt) then + mass_left = mass_act - mass_opt + pl_mass(j)%root(ipl)%m = mass_opt + else + pl_mass(j)%root(ipl)%m = pl_mass(j)%root(ipl)%m + pl_mass_up%m + mass_left = 0. + end if + !! next maintain harvest index on yield (seed/fruit) component + mass_act = pl_mass(j)%seed(ipl)%m + mass_opt = seed_mass_frac * pl_mass(j)%tot(ipl)%m + if (mass_act > mass_opt) then + mass_left = mass_act - mass_opt + pl_mass(j)%seed(ipl)%m = mass_opt + else + pl_mass(j)%seed(ipl)%m = pl_mass(j)%seed(ipl)%m + pl_mass_up%m + mass_left = 0. + end if + !! next maintain leaf component + mass_act = pl_mass(j)%leaf(ipl)%m + mass_opt = leaf_mass_frac * pl_mass(j)%tot(ipl)%m + if (mass_act > mass_opt) then + mass_left = mass_act - mass_opt + pl_mass(j)%leaf(ipl)%m = mass_opt + else + pl_mass(j)%leaf(ipl)%m = pl_mass(j)%leaf(ipl)%m + pl_mass_up%m + mass_left = 0. + end if + !! remainder goes to stem + pl_mass(j)%stem(ipl)%m = pl_mass(j)%stem(ipl)%m + mass_left + pl_mass(j)%ab_gr(ipl)%m = pl_mass(j)%stem(ipl)%m + pl_mass(j)%leaf(ipl)%m + pl_mass(j)%seed(ipl)%m + else + !! initialize at initial fractions pl_mass(j)%ab_gr(ipl)%m = ab_gr_frac * pl_mass(j)%tot(ipl)%m pl_mass(j)%root(ipl)%m = root_frac * pl_mass(j)%tot(ipl)%m pl_mass(j)%leaf(ipl)%m = leaf_mass_frac * pl_mass(j)%ab_gr(ipl)%m pl_mass(j)%seed(ipl)%m = seed_mass_frac * pl_mass(j)%ab_gr(ipl)%m pl_mass(j)%stem(ipl)%m = stem_mass_frac * pl_mass(j)%ab_gr(ipl)%m + end if !! partition carbon with constant fractions pl_mass(j)%leaf(ipl)%c = c_frac%leaf * pl_mass(j)%leaf(ipl)%m @@ -73,8 +115,8 @@ subroutine pl_partition(j) !! partition n and p if (pldb(idp)%typ == "perennial") then !! partition leaves and seed (stem is woody biomass) - m_left = pl_mass(j)%leaf(ipl)%m + pl_mass(j)%stem(ipl)%m + pl_mass(j)%root(ipl)%m - if (m_left > 1.e-9) then + mass_left = pl_mass(j)%leaf(ipl)%m + pl_mass(j)%stem(ipl)%m + pl_mass(j)%root(ipl)%m + if (mass_left > 1.e-9) then pl_mass(j)%seed(ipl)%n = pldb(idp)%cnyld * pl_mass(j)%seed(ipl)%m n_left = pl_mass(j)%tot(ipl)%n - pl_mass(j)%seed(ipl)%n !! if n is neg after seed is removed - assume 0 n in seed - plant database cnyld and fr_n_mat are off @@ -83,9 +125,9 @@ subroutine pl_partition(j) n_left = pl_mass(j)%seed(ipl)%n + n_left end if !! partition n_left between remaining masses - assume equal concentrations - pl_mass(j)%leaf(ipl)%n = n_left * pl_mass(j)%leaf(ipl)%m / m_left - pl_mass(j)%stem(ipl)%n = n_left * pl_mass(j)%stem(ipl)%m / m_left - pl_mass(j)%root(ipl)%n = n_left * pl_mass(j)%root(ipl)%m / m_left + pl_mass(j)%leaf(ipl)%n = n_left * pl_mass(j)%leaf(ipl)%m / mass_left + pl_mass(j)%stem(ipl)%n = n_left * pl_mass(j)%stem(ipl)%m / mass_left + pl_mass(j)%root(ipl)%n = n_left * pl_mass(j)%root(ipl)%m / mass_left pl_mass(j)%ab_gr(ipl)%n = pl_mass(j)%seed(ipl)%n + pl_mass(j)%leaf(ipl)%n + pl_mass(j)%stem(ipl)%n pl_mass(j)%seed(ipl)%p = pldb(idp)%cpyld * pl_mass(j)%seed(ipl)%m @@ -96,9 +138,9 @@ subroutine pl_partition(j) p_left = pl_mass(j)%seed(ipl)%p + p_left end if !! partition p_left between remaining masses - assume equal concentrations - pl_mass(j)%leaf(ipl)%p = p_left * pl_mass(j)%leaf(ipl)%m / m_left - pl_mass(j)%stem(ipl)%p = p_left * pl_mass(j)%stem(ipl)%m / m_left - pl_mass(j)%root(ipl)%p = p_left * pl_mass(j)%root(ipl)%m / m_left + pl_mass(j)%leaf(ipl)%p = p_left * pl_mass(j)%leaf(ipl)%m / mass_left + pl_mass(j)%stem(ipl)%p = p_left * pl_mass(j)%stem(ipl)%m / mass_left + pl_mass(j)%root(ipl)%p = p_left * pl_mass(j)%root(ipl)%m / mass_left pl_mass(j)%ab_gr(ipl)%p = pl_mass(j)%seed(ipl)%p + pl_mass(j)%leaf(ipl)%p + pl_mass(j)%stem(ipl)%p end if else diff --git a/src/pl_read_parms_cal.f90 b/src/pl_read_parms_cal.f90 index 573abf8..4594720 100644 --- a/src/pl_read_parms_cal.f90 +++ b/src/pl_read_parms_cal.f90 @@ -109,10 +109,10 @@ subroutine pl_read_parms_cal exit end do - end if + end if db_mx%plcal_reg = mreg - + close(107) return end subroutine pl_read_parms_cal \ No newline at end of file diff --git a/src/pl_read_regions_cal.f90 b/src/pl_read_regions_cal.f90 index 9b4f509..9db82ff 100644 --- a/src/pl_read_regions_cal.f90 +++ b/src/pl_read_regions_cal.f90 @@ -90,10 +90,10 @@ subroutine pl_read_regions_cal exit end do - end if + end if db_mx%plcal_reg = mreg - + close(107) return end subroutine pl_read_regions_cal \ No newline at end of file diff --git a/src/pl_root_gro.f90 b/src/pl_root_gro.f90 index f0df557..bbd9177 100644 --- a/src/pl_root_gro.f90 +++ b/src/pl_root_gro.f90 @@ -51,7 +51,7 @@ subroutine pl_root_gro(j) end if !! root mass - pl_mass(j)%root(ipl)%m = pcom(j)%plg(ipl)%root_frac * pl_mass(j)%tot(ipl)%m + !pl_mass(j)%root(ipl)%m = pcom(j)%plg(ipl)%root_frac * pl_mass(j)%tot(ipl)%m return end subroutine pl_root_gro \ No newline at end of file diff --git a/src/pl_rootfr.f90 b/src/pl_rootfr.f90 index 6ee7e8e..03b780d 100644 --- a/src/pl_rootfr.f90 +++ b/src/pl_rootfr.f90 @@ -1,7 +1,7 @@ - subroutine pl_rootfr - !! This subroutine distributes dead root mass through the soil profile - !! code developed by Armen R. Kemanian in 2008 - !! March, 2009 further adjustments expected + subroutine pl_rootfr + !! This subroutine distributes dead root mass through the soil profile + !! code developed by Armen R. Kemanian in 2008 + !! March, 2009 further adjustments expected use hru_module, only : ihru use soil_module @@ -9,13 +9,13 @@ subroutine pl_rootfr implicit none - real :: sol_thick(soil(ihru)%nly) ! | - real :: cum_rd = 0. ! | + real :: sol_thick(soil(ihru)%nly) ! | + real :: cum_rd = 0. ! | real :: cum_d = 0. ! | real :: cum_rf = 0. ! | real :: x1 = 0. ! | real :: x2 = 0. ! | - integer :: k = 0 ! | + integer :: k = 0 ! | integer :: l = 0 !none |number of soil layer that manure applied integer :: jj = 0 !none |counter real :: a = 0. ! | @@ -26,61 +26,61 @@ subroutine pl_rootfr real :: xx1 = 0. ! | real :: xx2 = 0. ! | real :: xx = 0. ! | - - jj = ihru + + jj = ihru if (pcom(jj)%plg(1)%root_dep < 1.e-6) then soil(jj)%ly(1)%rtfr = 1 return endif - ! Normalized Root Density = 1.15*exp[-11.7*NRD] + 0.022, where NRD = normalized rooting depth - ! Parameters of Normalized Root Density Function from Dwyer et al 19xx - a = 1.15 - b = 11.7 - c = 0.022 - d = 0.12029 ! Integral of Normalized Root Distribution Function - ! from 0 to 1 (normalized depth) = 0.12029 + ! Normalized Root Density = 1.15*exp[-11.7*NRD] + 0.022, where NRD = normalized rooting depth + ! Parameters of Normalized Root Density Function from Dwyer et al 19xx + a = 1.15 + b = 11.7 + c = 0.022 + d = 0.12029 ! Integral of Normalized Root Distribution Function + ! from 0 to 1 (normalized depth) = 0.12029 - l = 0 - k = 0 - cum_d = 0. - cum_rf = 0. + l = 0 + k = 0 + cum_d = 0. + cum_rf = 0. sol_thick(:) = 0. rtfr = 0. - do l = 1, soil(jj)%nly - if (l == 1) then - sol_thick(l) = soil(jj)%phys(l)%d - else - sol_thick(l) = soil(jj)%phys(l)%d - soil(jj)%phys(l-1)%d - end if - - cum_d = cum_d + sol_thick(l) - if (cum_d >= pcom(jj)%plg(1)%root_dep) cum_rd = pcom(jj)%plg(1)%root_dep - if (cum_d < pcom(jj)%plg(1)%root_dep) cum_rd = cum_d - x1 = (cum_rd - sol_thick(l)) / pcom(jj)%plg(1)%root_dep - x2 = cum_rd / pcom(jj)%plg(1)%root_dep + do l = 1, soil(jj)%nly + if (l == 1) then + sol_thick(l) = soil(jj)%phys(l)%d + else + sol_thick(l) = soil(jj)%phys(l)%d - soil(jj)%phys(l-1)%d + end if + + cum_d = cum_d + sol_thick(l) + if (cum_d >= pcom(jj)%plg(1)%root_dep) cum_rd = pcom(jj)%plg(1)%root_dep + if (cum_d < pcom(jj)%plg(1)%root_dep) cum_rd = cum_d + x1 = (cum_rd - sol_thick(l)) / pcom(jj)%plg(1)%root_dep + x2 = cum_rd / pcom(jj)%plg(1)%root_dep xx1 = -b * x1 - if (xx1 > 20.) xx1 = 20. + if (xx1 > 20.) xx1 = 20. xx2 = -b * x2 if (xx2 > 20.) xx2 = 20. - soil(jj)%ly(l)%rtfr = (a/b*(Exp(xx1) - Exp(xx2)) + c *(x2 - x1))/d + soil(jj)%ly(l)%rtfr = (a/b*(Exp(xx1) - Exp(xx2)) + c *(x2 - x1))/d xx = cum_rf - cum_rf = cum_rf + soil(jj)%ly(l)%rtfr + cum_rf = cum_rf + soil(jj)%ly(l)%rtfr if (cum_rf > 1.) then - soil(jj)%ly(l)%rtfr = 1. - xx + soil(jj)%ly(l)%rtfr = 1. - xx cum_rf = 1.0 end if - k = l - if (cum_rd >= pcom(jj)%plg(1)%root_dep) Exit - - end do + k = l + if (cum_rd >= pcom(jj)%plg(1)%root_dep) Exit + + end do - !! ensures that cumulative fractional root distribution = 1 - do l = 1, soil(jj)%nly - soil(jj)%ly(l)%rtfr = soil(jj)%ly(l)%rtfr / cum_rf - If (l == k) Exit ! exits loop on the same layer as the previous loop + !! ensures that cumulative fractional root distribution = 1 + do l = 1, soil(jj)%nly + soil(jj)%ly(l)%rtfr = soil(jj)%ly(l)%rtfr / cum_rf + If (l == k) Exit ! exits loop on the same layer as the previous loop end do return diff --git a/src/plant_all_init.f90 b/src/plant_all_init.f90 index f2f490f..2fd8741 100644 --- a/src/plant_all_init.f90 +++ b/src/plant_all_init.f90 @@ -15,6 +15,8 @@ subroutine plant_all_init integer :: num_plts_cur = 0 !none |temporary counter for number of different plants in basin allocate (plts_bsn(db_mx%plantparm)) + allocate (bsn_crop_yld(db_mx%plantparm)) + allocate (bsn_crop_yld_aa(db_mx%plantparm)) !!assign land use pointers for the hru !!allocate and initialize land use and management @@ -32,7 +34,7 @@ subroutine plant_all_init if (basin_plants == 0) then plts_bsn(1) = pcom(iihru)%pl(ipl) basin_plants = 1 - end if + else num_plts_cur = basin_plants do iplt = 1, num_plts_cur if (pcom(iihru)%pl(ipl) == plts_bsn(iplt)) exit @@ -41,26 +43,20 @@ subroutine plant_all_init basin_plants = basin_plants + 1 end if end do + end if end do end do - !! set all plants simulated in the basin - allocate (plants_bsn(basin_plants)) - allocate (bsn_crop_yld(basin_plants)) - allocate (bsn_crop_yld_aa(basin_plants)) - !! zero basin crop yields and harvested areas do ipl_bsn = 1, basin_plants bsn_crop_yld(ipl_bsn) = bsn_crop_yld_z bsn_crop_yld_aa(ipl_bsn) = bsn_crop_yld_z end do - plants_bsn = plts_bsn(1:basin_plants) - deallocate (plts_bsn) do iihru = 1, sp_ob%hru do ipl = 1, pcom(iihru)%npl do ipl_bsn = 1, basin_plants - if (pcom(iihru)%pl(ipl) == plants_bsn(ipl_bsn)) then + if (pcom(iihru)%pl(ipl) == plts_bsn(ipl_bsn)) then pcom(iihru)%plcur(ipl)%bsn_num = ipl_bsn exit end if diff --git a/src/plant_data_module.f90 b/src/plant_data_module.f90 index fa5f0c9..08b8d40 100644 --- a/src/plant_data_module.f90 +++ b/src/plant_data_module.f90 @@ -2,8 +2,7 @@ module plant_data_module implicit none - character(len=16), dimension (:), allocatable :: plts_bsn !none |plant names simulated in current run - character(len=16), dimension (:), allocatable :: plants_bsn !none |plant names simulated in current run - final + character(len=40), dimension (:), allocatable :: plts_bsn !none |plant names simulated in current run type plant_db character(len=40) :: plantnm = "" !none |crop name diff --git a/src/plant_init.f90 b/src/plant_init.f90 index 7520748..0030535 100644 --- a/src/plant_init.f90 +++ b/src/plant_init.f90 @@ -78,6 +78,9 @@ subroutine plant_init (init, iihru) deallocate (pcom(j)%plstr) deallocate (pcom(j)%plcur) deallocate (rsd1(j)%tot) + deallocate (rsd1(j)%meta) + deallocate (rsd1(j)%str) + deallocate (rsd1(j)%lignin) end if pcom(j)%npl = pcomdb(icom)%plants_com @@ -325,7 +328,7 @@ subroutine plant_init (init, iihru) if (pcom(j)%plcur(ipl)%gro == "y") then call pl_root_gro(j) call pl_seed_gro(j) - call pl_partition(j) + call pl_partition(j, 1) end if end do ! ipl loop diff --git a/src/plant_module.f90 b/src/plant_module.f90 index 05bbe64..5109822 100644 --- a/src/plant_module.f90 +++ b/src/plant_module.f90 @@ -92,7 +92,7 @@ module plant_module type fertilize_future !! set to the fert_fut action in the lum.dtl character(len=35) :: name = "" !! name of the fertilizer operation (from the dtbl) integer :: num = 0 !! number of the future fertilizer application (from the dtbl) - character(len=35) :: fertname = "" !! fertilizer name in fertilizer.frt + character(len=40) :: fertname = "" !! fertilizer name in fertilizer.frt integer :: fertnum = 0 !! fertilizer number in fertilizer.frt integer :: day_fert = 0 !! future julian day to apply fert (must be within a year of test) real :: fert_kg = 0. !! kg/ha - amount of fertilzer applied @@ -101,15 +101,15 @@ module plant_module end type fertilize_future type plant_community - character(len=35) :: name = "" + character(len=40) :: name = "" integer :: npl = 0 !! number of plants in community - character(len=16), dimension(:), allocatable :: pl !! N/A |plant name + character(len=40), dimension(:), allocatable :: pl !! N/A |plant name integer :: pcomdb = 0 !! current plant community database number integer :: rot_yr = 1 !! rotation year integer :: days_plant = 0 !! |days since last planting - for conditional scheduling planting integer :: days_harv = 0 !! |days since last harvest - for conditional scheduling planting integer :: days_irr = 0 !! |days since last irrigation - for conditional scheduling planting - character(len=16) :: last_kill = ""!! |name of last plant killed + character(len=40) :: last_kill = ""!! |name of last plant killed real :: cht_mx = 0. !! m |height of tallest plant in community for pet calculation real :: lai_sum = 0. !! m/m |sum of lai for each plant real :: laimx_sum = 0. !! m/m |sum of maximum lai for each plant - for canopy interception diff --git a/src/plantparm_init.f90 b/src/plantparm_init.f90 index 88e4ff5..87f1c55 100644 --- a/src/plantparm_init.f90 +++ b/src/plantparm_init.f90 @@ -22,11 +22,11 @@ subroutine plantparm_init if (pldb(ic)%usle_c >= 1.0) pldb(ic)%usle_c = 1.0 if (pldb(ic)%blai <= 0.0) pldb(ic)%blai = 0.0 if (pldb(ic)%blai >= 10.0) pldb(ic)%blai = 10.0 - if (pldb(ic)%rsr1 <= 0.0) pldb(ic)%rsr1 = 0.4 - if (pldb(ic)%rsr2 <= 0.0) pldb(ic)%rsr2 = 0.2 + if (pldb(ic)%rsr1 <= 0.0) pldb(ic)%rsr1 = 0.4 + if (pldb(ic)%rsr2 <= 0.0) pldb(ic)%rsr2 = 0.2 if (pldb(ic)%aeration <= 0.0) pldb(ic)%aeration = 0.2 - if (pldb(ic)%rsd_pctcov <= 0.0) pldb(ic)%rsd_pctcov = 0.4 - if (pldb(ic)%rsd_covfac <= 0.0) pldb(ic)%rsd_covfac = 0.04 + if (pldb(ic)%rsd_pctcov <= 0.0) pldb(ic)%rsd_pctcov = 0.4 + if (pldb(ic)%rsd_covfac <= 0.0) pldb(ic)%rsd_covfac = 0.04 !! check if tuber, root to total biomass ratio = 0.7 if (pldb(ic)%typ == "warm_annual_tuber" .or. pldb(ic)%typ == "cold_annual_tuber") then diff --git a/src/proc_bsn.f90 b/src/proc_bsn.f90 index c50336a..3b4491b 100644 --- a/src/proc_bsn.f90 +++ b/src/proc_bsn.f90 @@ -12,7 +12,7 @@ subroutine proc_bsn write (9001,*) "DIAGNOSTICS.OUT FILE" !!! open drainage areas output file open (9004,file="area_calc.out", recl=8000) - + call basin_read_cc call basin_read_objs call time_read diff --git a/src/rec_read_elements.f90 b/src/rec_read_elements.f90 index 3b8f363..a9e56c7 100644 --- a/src/rec_read_elements.f90 +++ b/src/rec_read_elements.f90 @@ -72,7 +72,7 @@ subroutine rec_read_elements db_mx%rec_out = mreg end do - end if + end if !! setting up regions for recall soft cal and/or output by type inquire (file=in_regs%def_psc_reg, exist=i_exist) @@ -116,7 +116,7 @@ subroutine rec_read_elements db_mx%rec_reg = mreg end do - end if + end if !! if no regions are input, don"t need elements if (mreg > 0) then diff --git a/src/recall_nut.f90 b/src/recall_nut.f90 index 5b290b2..6a3379f 100644 --- a/src/recall_nut.f90 +++ b/src/recall_nut.f90 @@ -84,7 +84,7 @@ subroutine recall_nut(irec) endif -100 format(i8,i8,100e16.8) +!*** tu Wunused-label: 100 format(i8,i8,100e16.8) return end subroutine recall_nut \ No newline at end of file diff --git a/src/recall_read.f90 b/src/recall_read.f90 index b1649c5..ba4f4c3 100644 --- a/src/recall_read.f90 +++ b/src/recall_read.f90 @@ -161,6 +161,8 @@ subroutine recall_read case (2) !! monthly read (108,*,iostat=eof) jday, mo, day_mo, iyr, ob_typ, ob_name, & recall(i)%hd(mo1,iyrs) + write (10108,*) jday, mo, day_mo, iyr, ob_typ, ob_name, & + recall(i)%hd(mo1,iyrs) case (3) !! annual read (108,*,iostat=eof) jday, mo, day_mo, iyr, ob_typ, ob_name, ht1 recall(i)%hd(1,iyrs) = ht1 diff --git a/src/recall_salt.f90 b/src/recall_salt.f90 index c33f25a..594bd3a 100644 --- a/src/recall_salt.f90 +++ b/src/recall_salt.f90 @@ -81,7 +81,7 @@ subroutine recall_salt(irec) enddo if(rec_salt(irec)%pts_type.eq.1) then do isalt=1,cs_db%num_salts - recsaltb_d(irec)%salt(isalt) = rec_salt(irec)%hd_salt(1,time%yrs)%salt(isalt) + recsaltb_d(irec)%salt(isalt) = rec_salt(irec)%hd_salt(1,time%yrs)%salt(isalt) enddo else do isalt=1,cs_db%num_salts diff --git a/src/reg_read_elements.f90 b/src/reg_read_elements.f90 index d228675..d83f1e4 100644 --- a/src/reg_read_elements.f90 +++ b/src/reg_read_elements.f90 @@ -122,7 +122,7 @@ subroutine reg_read_elements end do ! i = 1, mreg end do - end if + end if !!read data for each element in all landscape cataloging units inquire (file=in_regs%ele_reg, exist=i_exist) diff --git a/src/res_control.f90 b/src/res_control.f90 index d04c488..18e78d6 100644 --- a/src/res_control.f90 +++ b/src/res_control.f90 @@ -76,8 +76,8 @@ subroutine res_control (jres) res_ob(jres)%prev_flo = ht2%flo call res_sediment - else - ictbl = res_dat(idat)%release !! Osvaldo + else + ictbl = res_dat(idat)%release !! Osvaldo call res_rel_conds (ictbl, res(jres)%flo, ht1%flo, 0.) endif diff --git a/src/res_cs.f90 b/src/res_cs.f90 index ff43035..569264d 100644 --- a/src/res_cs.f90 +++ b/src/res_cs.f90 @@ -24,7 +24,7 @@ subroutine res_cs(jres, icon, iob) !rtb cs real :: cs_conc = 0. !concentration of constituent in reservoir water (g/m3 = mg/L) integer :: icmd = 0 !none real :: k_react = 0. !1/day - first-order rate constant, affected by temperature - real :: v_settle = 0. !m/day - settling rate + real :: v_settle = 0. !m/day - settling rate real :: cs_mass_beg = 0. real :: cs_conc_beg = 0. real :: cs_mass_end = 0. @@ -87,11 +87,11 @@ subroutine res_cs(jres, icon, iob) !rtb cs !constituent mass settling to bottom of reservoir if(ics == 1) then v_settle = res_cs_data(icon)%v_seo4 - elseif(ics == 2) then + elseif(ics == 2) then v_settle = res_cs_data(icon)%v_seo3 - elseif(ics == 3) then + elseif(ics == 3) then v_settle = res_cs_data(icon)%v_born - endif + endif cs_settle = (cs_conc_beg/1000.) * v_settle * (res_wat_d(jres)%area_ha*10000.) !kg if(cs_settle > mass_avail) then cs_settle = mass_avail !take remaining diff --git a/src/res_cs_module.f90 b/src/res_cs_module.f90 index a0323bc..b6e8478 100644 --- a/src/res_cs_module.f90 +++ b/src/res_cs_module.f90 @@ -28,7 +28,7 @@ module res_cs_module !rtb cs type (res_cs_output), dimension(:), allocatable, save :: rescs_m type (res_cs_output), dimension(:), allocatable, save :: rescs_y type (res_cs_output), dimension(:), allocatable, save :: rescs_a - + !arrays for wetland mass balance output type (res_cs_output), dimension(:), allocatable, save :: wetcs_d type (res_cs_output), dimension(:), allocatable, save :: wetcs_m diff --git a/src/res_hydro.f90 b/src/res_hydro.f90 index c5a97a2..1aa25e0 100644 --- a/src/res_hydro.f90 +++ b/src/res_hydro.f90 @@ -21,23 +21,32 @@ subroutine res_hydro (jres, id, pvol_m3, evol_m3) integer :: tstep = 0 !none |hru number integer :: iac = 0 !none |counter integer :: ic = 0 !none |counter + !integer :: weir_flg=0 !none |counter integer, intent (in) :: id !none |hru number integer :: ial = 0 !none |counter integer :: irel = 0 ! | integer :: iob = 0 !none |hru or wro number real :: vol = 0. ! | + real :: vol_above = 0. ! | real :: b_lo = 0. ! | character(len=1) :: action = ""! | real :: res_h = 0. !m |water depth real :: demand = 0. !m3 |irrigation demand by hru or wro real :: wsa1 = 0. !m2 |water surface area + real :: qout = 0. !m3 |weir discharge during short time step + real :: hgt = 0. !m |height of bottom of weir above bottom of impoundment real :: hgt_above = 0. !m |height of water above the above bottom of weir - real :: alpha_e = 0. + real :: sto_max = 0. !m3 |maximum storage volume at the bank top !! store initial values vol = wbody%flo nstep = 1 wsa1 = wbody_wb%area_ha * 10000. !m2 + if (time%step>0) then !Jaehak 2024 + nstep = time%step + else + nstep = 1 + end if do tstep = 1, nstep @@ -90,6 +99,8 @@ subroutine res_hydro (jres, id, pvol_m3, evol_m3) end select ht2%flo = ht2%flo + (wbody%flo - b_lo) / d_tbl%act(iac)%const / nstep ht2%flo = max(0.,ht2%flo) + !wbody%flo = max(0.,wbody%flo - ht2%flo) + vol = wbody%flo case ("dyrt") !! release based on drawdown days + percentage of principal volume @@ -157,8 +168,32 @@ subroutine res_hydro (jres, id, pvol_m3, evol_m3) case ("weir") !! release based on weir equation - res_h = vol / (wbody_wb%area_ha * 10000.) !m + iweir = d_tbl%act_typ(iac) + res_h = vol / wsa1 !m hgt_above = max(0., res_h - wet_ob(jres)%weir_hgt) !m + if (nstep>24) then !hourly interval + ht2%flo = res_weir(iweir)%c * res_weir(iweir)%w * hgt_above ** res_weir(iweir)%k !m3/s + ht2%flo = max(0.,86400. / nstep * ht2%flo) !m3 + vol = vol - ht2%flo + else + do ic = 1, 24 + vol_above = hgt_above * wsa1 !m3 water volume above weir height + qout = res_weir(iweir)%c * res_weir(iweir)%w * hgt_above ** res_weir(iweir)%k !m3/s + qout = 3600. * qout !m3 + if (qout > vol_above) then + ht2%flo = ht2%flo + vol_above !weir discharge volume for the day, m3 + vol = vol - vol_above + else + ht2%flo = ht2%flo + qout + vol = vol - qout + end if + res_h = vol / wsa1 !m + hgt_above = max(0.,res_h - wet_ob(jres)%weir_hgt) !m Jaehak 2022 + if (vol_above<=0.001.or.hgt_above<=0.0001) exit + end do + endif + res_h = vol / wsa1 !m + wbody%flo = vol !m3 iweir = d_tbl%act_typ(iac) ht2%flo = ht2%flo + res_weir(iweir)%c * res_weir(iweir)%w * hgt_above ** res_weir(iweir)%k / nstep !m3/s ht2%flo = ht2%flo + max(0.,ht2%flo) diff --git a/src/res_nutrient.f90 b/src/res_nutrient.f90 index cf009e1..6e4bd00 100644 --- a/src/res_nutrient.f90 +++ b/src/res_nutrient.f90 @@ -89,13 +89,13 @@ subroutine res_nutrient (iob) ht2%no2 = wbody%no2 * ht2%flo / (wbody%flo + ht2%flo) !! remove nutrients leaving reservoir - wbody%no3 = wbody%no3 - ht2%no3 - wbody%orgn = wbody%orgn - ht2%orgn - wbody%sedp = wbody%sedp - ht2%sedp - wbody%solp = wbody%solp - ht2%solp - wbody%chla = wbody%chla - ht2%chla - wbody%nh3 = wbody%nh3 - ht2%nh3 - wbody%no2 = wbody%no2 - ht2%no2 + wbody%no3 = max(0.,wbody%no3 - ht2%no3) !No less than zero, Jaehak 2024 + wbody%orgn = max(0.,wbody%orgn - ht2%orgn) + wbody%sedp = max(0.,wbody%sedp - ht2%sedp) + wbody%solp = max(0.,wbody%solp - ht2%solp) + wbody%chla = max(0.,wbody%chla - ht2%chla) + wbody%nh3 = max(0.,wbody%nh3 - ht2%nh3) + wbody%no2 = max(0.,wbody%no2 - ht2%no2) return end subroutine res_nutrient \ No newline at end of file diff --git a/src/res_read.f90 b/src/res_read.f90 index d75d649..80fb3b4 100644 --- a/src/res_read.f90 +++ b/src/res_read.f90 @@ -109,6 +109,7 @@ subroutine res_read do ihyd = 1, db_mx%res_hyd if (res_hyddb(ihyd)%name == res_dat_c(ires)%hyd) then res_hyd(ires) = res_hyddb(ihyd) + res_dat(ires)%hyd = ihyd exit end if end do @@ -134,6 +135,9 @@ subroutine res_read do ised = 1, db_mx%res_sed if (res_sed(ised)%name == res_dat_c(ires)%sed) then res_prm(ires)%sed = res_sed(ised) + !! d50 - micro meters + res_prm(ires)%sed_stlr_co = exp(-0.184 * res_prm(ires)%sed%d50) + res_dat(ires)%sed = ised exit end if end do @@ -141,6 +145,7 @@ subroutine res_read do inut = 1, db_mx%res_nut if (res_nut(inut)%name == res_dat_c(ires)%nut) then res_prm(ires)%nut = res_nut(inut) + res_dat(ires)%nut = inut exit end if end do diff --git a/src/res_salt_module.f90 b/src/res_salt_module.f90 index b30142b..cfb020c 100644 --- a/src/res_salt_module.f90 +++ b/src/res_salt_module.f90 @@ -24,7 +24,7 @@ module res_salt_module !rtb salt type (res_salt_output), dimension(:), allocatable, save :: ressalt_m type (res_salt_output), dimension(:), allocatable, save :: ressalt_y type (res_salt_output), dimension(:), allocatable, save :: ressalt_a - + !arrays for wetland mass balance output type (res_salt_output), dimension(:), allocatable, save :: wetsalt_d type (res_salt_output), dimension(:), allocatable, save :: wetsalt_m diff --git a/src/res_sediment.f90 b/src/res_sediment.f90 index 35d0575..6f59e06 100644 --- a/src/res_sediment.f90 +++ b/src/res_sediment.f90 @@ -21,54 +21,33 @@ subroutine res_sediment wbody = hz else - !! compute new sediment concentration in reservoir - if (ht1%sed < 1.e-6) ht1%sed = 0.0 - !! velsetl = 1.35 for clay particle m/d - if (wbody_wb%area_ha > 1.e-6) then - velofl = (ht1%flo / wbody_wb%area_ha) / 10000. ! m3/d / ha * 10000. = m/d - if (velofl > 1.e-6) then - trapres = wbody_prm%sed%velsetlr / velofl - else - trapres = 1. - end if - if (trapres > 1.) trapres = 1. - else - trapres = 1. - end if - !wbody%sed = wbody%sed - (ht1%sed * trapres) - !wbody%sil = wbody%sil - (ht1%sil * trapres) - !wbody%cla = wbody%cla - (ht1%cla * trapres) - !! compute concentrations - if (wbody%flo > 0.) then + if (wbody%flo > 0.) then sed_ppm = 1000000. * wbody%sed / wbody%flo sed_ppm = Max(1.e-6, sed_ppm) sil_ppm = 1000000. * wbody%sil / wbody%flo sil_ppm = Max(1.e-6, sil_ppm) cla_ppm = 1000000. * wbody%cla / wbody%flo cla_ppm = Max(1.e-6, cla_ppm) - else + else sed_ppm = 1.e-6 sil_ppm = 1.e-6 cla_ppm = 1.e-6 - endif + endif !! compute change in sediment concentration due to settling if (sed_ppm > wbody_prm%sed%nsed) then - wbody_prm%sed%sed_stlr = exp(-wbody_prm%sed%sed_stlr) - sed_ppm = (sed_ppm - wbody_prm%sed%nsed) * wbody_prm%sed%sed_stlr + wbody_prm%sed%nsed + sed_ppm = (sed_ppm - wbody_prm%sed%nsed) * wbody_prm%sed_stlr_co + wbody_prm%sed%nsed sed_ppm = Max (sed_ppm, wbody_prm%sed%nsed) - !wbody%sed = sed_ppm * wbody%flo / 1000000. ! ppm -> t + !! update wetland sediment after settling + wbody%sed = sed_ppm * wbody%flo / 1000000. + !! calculate sediment in the outflow and subtract from wetland ht2%sed = sed_ppm * ht2%flo / 1000000. - wbody%sed = wbody%sed - ht2%sed + wbody%sed = Max(0.,wbody%sed - ht2%sed) - sil_ppm = (sil_ppm - wbody_prm%sed%nsed) * wbody_prm%sed%sed_stlr + wbody_prm%sed%nsed - wbody%sil = sil_ppm * wbody%flo / 1000000. ! ppm -> t - - cla_ppm = (cla_ppm - wbody_prm%sed%nsed) * wbody_prm%sed%sed_stlr + wbody_prm%sed%nsed - wbody%cla = cla_ppm * wbody%flo / 1000000. ! ppm -> t - !! assume all sand aggregates and gravel settles + wbody%sil = 0. + wbody%cla = 0. wbody%san = 0. wbody%sag = 0. wbody%lag = 0. @@ -78,10 +57,6 @@ subroutine res_sediment !! compute sediment leaving reservoir - ppm -> t ht2%sed = sed_ppm * ht2%flo / 1000000. wbody%sed = wbody%sed - ht2%sed - ht2%sil = sil_ppm * ht2%flo / 1000000. - wbody%sil = wbody%sil - ht2%sil - ht2%cla = cla_ppm * ht2%flo / 1000000. - wbody%cla = wbody%cla - ht2%cla end if diff --git a/src/res_weir_release.f90 b/src/res_weir_release.f90 index d72cb8e..3e30e45 100644 --- a/src/res_weir_release.f90 +++ b/src/res_weir_release.f90 @@ -31,11 +31,13 @@ subroutine res_weir_release (jres, id, ihyd, evol_m3, dep, weir_hgt) real :: wsa1 = 0. !m2 |water surface area real :: qout = 0. !m3 |weir discharge during short time step real :: hgt_above = 0. !m |height of water above the above bottom of weir + real :: vol_above = 0. !m3 |water volume above the bottom of weir !Jaehak 2024 !! store initial values vol = wbody%flo nstep = 1 - iweir = bsn_cc%cn + iweir = wet_ob(jres)%iweir + vol_above = 0 !water storage above weir height if (wet_hyd(ihyd)%name=='paddy') then !paddy @@ -54,15 +56,17 @@ subroutine res_weir_release (jres, id, ihyd, evol_m3, dep, weir_hgt) !endif !write(*,'(10f10.1)') w%precip,vol/wsa1*1000,ht2%flo/wsa1*1000,hru(jres)%water_seep,soil(jres)%sw !! check if reservoir decision table has a weir discharge command - do iac = 1, dtbl_res(id)%acts - if (dtbl_res(id)%act(iac)%option == "weir") then - weir_flg = 1 - exit - endif - end do + ! do iac = 1, dtbl_res(id)%acts + ! if (dtbl_res(id)%act(iac)%option == "weir") then + ! weir_flg = 1 + ! exit + ! endif + ! end do do tstep = 1, nstep + !! calculate weir discharge from scheduled management + if (hgt_above > 0 .and. iweir > 0) then !emergency spillway discharge Jaehak 2023 if (vol>evol_m3) then ht2%flo = ht2%flo + (wbody%flo - evol_m3) @@ -71,31 +75,36 @@ subroutine res_weir_release (jres, id, ihyd, evol_m3, dep, weir_hgt) res_h = vol / wsa1 !m hgt_above = max(0.,res_h - weir_hgt) !m endif + vol_above = hgt_above * wsa1 !m3 if (nstep>1) then !revised by Jaehak 2023 qout = res_weir(iweir)%c * res_weir(iweir)%w * hgt_above ** res_weir(iweir)%k !m3/s qout = max(0.,86400. / nstep * qout) !m3 - if (qout > vol) then - ht2%flo = ht2%flo + vol !weir discharge volume for the day, m3 - vol = 0. + if (qout > vol_above) then + ht2%flo = ht2%flo + vol_above !weir discharge volume for the day, m3 + vol = vol - vol_above + vol_above = 0. else ht2%flo = ht2%flo + qout vol = vol - qout + vol_above = vol_above - qout end if res_h = vol / wsa1 !m hgt_above = max(0.,res_h - weir_hgt) !m Jaehak 2022 - if (vol==0.or.hgt_above==0) exit + if (vol_above<=0.001.or.hgt_above<=0.0001) exit else do ic = 1, 24 qout = res_weir(iweir)%c * res_weir(iweir)%w * hgt_above ** res_weir(iweir)%k !m3/s qout = 3600. * qout !m3 - if (qout > vol) then - ht2%flo = ht2%flo + vol !weir discharge volume for the day, m3 - vol = 0. + if (qout > vol_above) then + ht2%flo = ht2%flo + vol_above !weir discharge volume for the day, m3 + vol = vol - vol_above + vol_above = 0. else ht2%flo = ht2%flo + qout vol = vol - qout + vol_above = vol_above - qout end if if (wsa1 > 1.e-6) then @@ -104,9 +113,13 @@ subroutine res_weir_release (jres, id, ihyd, evol_m3, dep, weir_hgt) res_h = 0. end if hgt_above = max(0.,res_h - weir_hgt) !m Jaehak 2022 - if (vol==0.or.hgt_above==0) exit + if (vol_above<=0.001.or.hgt_above<=0.0001) exit end do endif + else + ht2%flo = 0. + endif + wbody%flo = vol !m3 end do return diff --git a/src/reservoir_data_module.f90 b/src/reservoir_data_module.f90 index fa3b706..b49c55d 100644 --- a/src/reservoir_data_module.f90 +++ b/src/reservoir_data_module.f90 @@ -98,7 +98,7 @@ module reservoir_data_module type reservoir_sed_data character(len=25) :: name = "" real :: nsed = 0. !kg/L |normal amt of sed in res (read in as mg/L and convert to kg/L) - real :: d50 = 0. !mm |median particle size of suspended and benthic sediment + real :: d50 = 0. !um |median particle size of suspended and benthic sediment real :: carbon = 0. !% |organic carbon in suspended and benthic sediment real :: bd = 0. !t/m^3 |bulk density of benthic sediment real :: sed_stlr = 0. !none |sediment settling rate @@ -126,6 +126,7 @@ module reservoir_data_module type water_body_data_parameters type (reservoir_sed_data) :: sed type (reservoir_nut_data) :: nut + real :: sed_stlr_co = 0. !none | end type water_body_data_parameters type (water_body_data_parameters), dimension(:), allocatable, target :: res_prm type (water_body_data_parameters), dimension(:), allocatable, target :: wet_prm diff --git a/src/rsd_decomp.f90 b/src/rsd_decomp.f90 new file mode 100644 index 0000000..329aa81 --- /dev/null +++ b/src/rsd_decomp.f90 @@ -0,0 +1,171 @@ + subroutine rsd_decomp + +!! ~ ~ ~ PURPOSE ~ ~ ~ +!! this subroutine estimates daily nitrogen and phosphorus +!! mineralization and immobilization considering fresh organic +!! material (plant residue) and active and stable humus material + +!! ~ ~ ~ INCOMING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! ihru |none |HRU number +!! rsdco_pl(:) |none |plant residue decomposition coefficient. The +!! |fraction of residue which will decompose in +!! |a day assuming optimal moisture, +!! |temperature, C:N ratio, and C:P ratio +!!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ +!! name |units |definition +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ +!! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +!! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ +!! Intrinsic: Max, Exp, Sqrt, Min, Abs + +!! ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~ + + use plant_data_module + use basin_module + use organic_mineral_mass_module + use hru_module, only : rsdco_plcom, i_sep, ihru, ipl, isep + use soil_module + use plant_module + use output_landscape_module, only : hnb_d + use carbon_module, only : hrc_d + + implicit none + + integer :: j = 0 !none |HRU number + integer :: k = 0 !none |counter (soil layer) + integer :: kk = 0 !none |soil layer used to compute soil water and + ! |soil temperature factors + integer :: idp = 0 + real :: rmn1 = 0. !kg N/ha |amount of nitrogen moving from fresh organic + ! |to nitrate(80%) and active organic(20%) + ! |pools in layer + real :: rmp = 0. ! |to labile(80%) and organic(20%) pools in layer + real :: xx = 0. !varies |variable to hold intermediate calculation result + real :: csf = 0. !none |combined temperature/soil water factor + real :: cnr = 0. ! |carbon nitrogen ratio + real :: cnrf = 0. ! |carbon nitrogen ratio factor + real :: cpr = 0. ! |carbon phosphorus ratio + real :: cprf = 0. ! |carbon phosphorus ratio factor + real :: ca = 0. ! | + real :: decr = 0. ! | + real :: rdc = 0. ! | + real :: cdg = 0. !none |soil temperature factor + real :: sut = 0. !none |soil water factor + + j = ihru + + !zero transformations for summing layers + hnb_d(j)%rsd_nitorg_n = 0. + hnb_d(j)%rsd_laborg_p = 0. + + !! mineralization can occur only if temp above 0 deg + if (soil(j)%phys(1)%tmp > 0.) then + rsd1(j)%tot_com = orgz + if (bsn_cc%cswat == 2) then + rsd1(j)%tot_meta = orgz + rsd1(j)%tot_str = orgz + rsd1(j)%tot_lignin = orgz + end if + + !! compute residue decomp and mineralization of fresh organic n and p of flat residue + do ipl = 1, pcom(j)%npl !! we need to decompose each plant + rmn1 = 0. + rmp = 0. + if (rsd1(j)%tot(ipl)%n > 1.e-4) then + cnr = rsd1(j)%tot(ipl)%c / rsd1(j)%tot(ipl)%n + if (cnr > 500.) cnr = 500. + cnrf = Exp(-.693 * (cnr - 25.) / 25.) + else + cnrf = 1. + end if + + if (rsd1(j)%tot(ipl)%p > 1.e-4) then + cpr = rsd1(j)%tot(ipl)%c / rsd1(j)%tot(ipl)%p + if (cpr > 5000.) cpr = 5000. + cprf = Exp(-.693 * (cpr - 200.) / 200.) + else + cprf = 1. + end if + + !! compute soil water factor + if (soil(j)%phys(1)%st < 0.) soil(j)%phys(1)%st = .0000001 + sut = .1 + .9 * Sqrt(soil(j)%phys(1)%st / soil(j)%phys(1)%fc) + sut = Max(.05, sut) + + !!compute soil temperature factor + xx = soil(j)%phys(1)%tmp + cdg = .9 * xx / (xx + Exp(9.93 - .312 * xx)) + .1 + cdg = Max(.1, cdg) + + !! compute combined factor + xx = cdg * sut + if (xx < 0.) xx = 0. + if (xx > 1.e6) xx = 1.e6 + csf = Sqrt(xx) + ca = Min(cnrf, cprf, 1.) + !! compute residue decomp and mineralization for each plant + if (pcom(j)%npl > 0) then + idp = pcom(j)%plcur(ipl)%idplt + decr = pldb(idp)%rsdco_pl * ca * csf + else + decr = 0.05 * ca * csf + end if + decr = Max(bsn_prm%decr_min, decr) + decr = Min(decr, 1.) + + !! mineralization of mass and carbon + rsd1(j)%tot(ipl)%m = Max(1.e-6, rsd1(j)%tot(ipl)%m) + rdc = decr * rsd1(j)%tot(ipl)%m + rsd1(j)%tot(ipl)%m = rsd1(j)%tot(ipl)%m - rdc + if (rsd1(j)%tot(ipl)%m < 0.) rsd1(j)%tot(ipl)%m = 0. + + !! apply decay to total carbon pool + rsd1(j)%tot(ipl)%c = (1. - decr) * rsd1(j)%tot(ipl)%c + if (rsd1(j)%tot(ipl)%c < 0.) rsd1(j)%tot(ipl)%c = 0. + soil1(j)%hact(1)%c = soil1(j)%hact(1)%c + decr * rsd1(j)%tot(ipl)%c + + !! apply decay to all carbon pools + if (bsn_cc%cswat == 2) then + rsd1(j)%meta(ipl) = (1. - decr) * rsd1(j)%meta(ipl) + rsd1(j)%str(ipl) = (1. - decr) * rsd1(j)%str(ipl) + rsd1(j)%lignin(ipl) = (1. - decr) * rsd1(j)%lignin(ipl) + end if + + !! mineralization of residue n and p + rmn1 = decr * rsd1(j)%tot(ipl)%n + rsd1(j)%tot(ipl)%n = Max(1.e-6, rsd1(j)%tot(ipl)%n) + rsd1(j)%tot(ipl)%n = rsd1(j)%tot(ipl)%n - rmn1 + soil1(j)%mn(1)%no3 = soil1(j)%mn(1)%no3 + .8 * rmn1 + soil1(j)%hact(1)%n = soil1(j)%hact(1)%n + .2 * rmn1 + + rsd1(j)%tot(ipl)%p = Max(1.e-6, rsd1(j)%tot(ipl)%p) + rmp = decr * rsd1(j)%tot(ipl)%p + rsd1(j)%tot(ipl)%p = rsd1(j)%tot(ipl)%p - rmp + soil1(j)%mp(1)%lab = soil1(j)%mp(1)%lab + .8 * rmp + soil1(j)%hact(1)%p = soil1(j)%hact(1)%p + .2 * rmp + + hnb_d(j)%rsd_nitorg_n = hnb_d(j)%rsd_nitorg_n + .8 * rmn1 + hnb_d(j)%rsd_laborg_p = hnb_d(j)%rsd_laborg_p + .8 * rmp + + !! sum total residue pools + rsd1(j)%tot_com = rsd1(j)%tot_com + rsd1(j)%tot(ipl) + if (bsn_cc%cswat == 2) then + rsd1(j)%tot_meta = rsd1(j)%tot_meta + rsd1(j)%meta(ipl) + rsd1(j)%tot_str = rsd1(j)%tot_str + rsd1(j)%str(ipl) + rsd1(j)%tot_lignin = rsd1(j)%tot_lignin + rsd1(j)%lignin(ipl) + end if + + end do ! ipl = 1, pcom(j)%npl + end if ! soil temperature > 0. + + return + end subroutine rsd_decomp \ No newline at end of file diff --git a/src/ru_cs_output.f90 b/src/ru_cs_output.f90 index 0e43ba1..7792664 100644 --- a/src/ru_cs_output.f90 +++ b/src/ru_cs_output.f90 @@ -10,7 +10,7 @@ subroutine ru_cs_output(iru) !rtb cs integer, intent (in) :: iru ! | integer :: iob = 0 ! | - integer :: ics = 0 ! |constituent counter + integer :: ics = 0 ! |constituent counter integer :: ihyd = 0 ! |hydrograph counter !! ~ ~ ~ PURPOSE ~ ~ ~ @@ -64,7 +64,7 @@ subroutine ru_cs_output(iru) !rtb cs (ru_hru_csb_d(iru)%cs(ics)%sorb,ics=1,cs_db%num_cs) if (pco%csvout == "y") then write (6071,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iru, ob(iob)%gis_id, & - (rucsb_d(iru)%hd(1)%cs(ics),ics=1,cs_db%num_cs), & !total out + (rucsb_d(iru)%hd(1)%cs(ics),ics=1,cs_db%num_cs), & !total out (rucsb_d(iru)%hd(2)%cs(ics),ics=1,cs_db%num_cs), & !percolation (rucsb_d(iru)%hd(3)%cs(ics),ics=1,cs_db%num_cs), & !surface runoff (rucsb_d(iru)%hd(4)%cs(ics),ics=1,cs_db%num_cs), & !soil lateral flow diff --git a/src/ru_output.f90 b/src/ru_output.f90 index 3184522..48e7da1 100644 --- a/src/ru_output.f90 +++ b/src/ru_output.f90 @@ -60,7 +60,7 @@ subroutine ru_output (iru) return -100 format (4i6,2i8,25f15.3) -102 format (4i6,2i8,25f15.3) +!*** tu Wunused-label: 100 format (4i6,2i8,25f15.3) +!*** tu Wunused-label: 102 format (4i6,2i8,25f15.3) end subroutine ru_output \ No newline at end of file diff --git a/src/ru_salt_output.f90 b/src/ru_salt_output.f90 index 5156c34..9265186 100644 --- a/src/ru_salt_output.f90 +++ b/src/ru_salt_output.f90 @@ -64,7 +64,7 @@ subroutine ru_salt_output(iru) !rtb salt ru_hru_saltb_d(iru)%salt(1)%diss if (pco%csvout == "y") then write (5071,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iru, ob(iob)%gis_id, & - (rusaltb_d(iru)%hd(1)%salt(isalt),isalt=1,cs_db%num_salts), & + (rusaltb_d(iru)%hd(1)%salt(isalt),isalt=1,cs_db%num_salts), & (rusaltb_d(iru)%hd(2)%salt(isalt),isalt=1,cs_db%num_salts), & (rusaltb_d(iru)%hd(3)%salt(isalt),isalt=1,cs_db%num_salts), & (rusaltb_d(iru)%hd(4)%salt(isalt),isalt=1,cs_db%num_salts), & @@ -299,7 +299,7 @@ subroutine ru_salt_output(iru) !rtb salt (ru_hru_saltb_a(iru)%salt(isalt)%rain,isalt=1,cs_db%num_salts), & (ru_hru_saltb_a(iru)%salt(isalt)%dryd,isalt=1,cs_db%num_salts), & (ru_hru_saltb_a(iru)%salt(isalt)%road,isalt=1,cs_db%num_salts), & - (ru_hru_saltb_a(iru)%salt(isalt)%fert,isalt=1,cs_db%num_salts), & + (ru_hru_saltb_a(iru)%salt(isalt)%fert,isalt=1,cs_db%num_salts), & (ru_hru_saltb_a(iru)%salt(isalt)%amnd,isalt=1,cs_db%num_salts), & (ru_hru_saltb_a(iru)%salt(isalt)%uptk,isalt=1,cs_db%num_salts), & ru_hru_saltb_a(iru)%salt(1)%diss diff --git a/src/salt_balance.f90 b/src/salt_balance.f90 index 637396b..08f3792 100644 --- a/src/salt_balance.f90 +++ b/src/salt_balance.f90 @@ -499,14 +499,14 @@ subroutine salt_balance gwsol_ss(i)%solute(2+m)%rcti = 0. gwsol_ss(i)%solute(2+m)%rcto = 0. gwsol_ss(i)%solute(2+m)%minl = 0. - enddo + enddo enddo endif endif 7000 format(i8,i8,i8,35e16.8) -7001 format(20e16.8) +!*** tu Wunused-label: 7001 format(20e16.8) return end \ No newline at end of file diff --git a/src/salt_chem_hru.f90 b/src/salt_chem_hru.f90 index 757a110..0281bce 100644 --- a/src/salt_chem_hru.f90 +++ b/src/salt_chem_hru.f90 @@ -198,29 +198,29 @@ subroutine salt_chem_hru if(K_ADJ1.gt.0.) then salt_K1 = Ksp11/K_ADJ1 - else + else salt_K1 = 0. - endif + endif if(K_ADJ2.gt.0.) then salt_K2 = Ksp21/K_ADJ2 - else + else salt_K2 = 0. - endif + endif if(K_ADJ3.gt.0.) then salt_K3 = Ksp31/K_ADJ3 - else + else salt_K3 = 0. - endif + endif if(K_ADJ4.gt.0.) then salt_K4 = Ksp41/K_ADJ4 - else + else salt_K4 = 0. - endif + endif if(K_ADJ5.gt.0.) then salt_K5 = Ksp51/K_ADJ5 - else + else salt_K5 = 0. - endif + endif errorTotal = 1 @@ -365,7 +365,7 @@ subroutine salt_chem_hru mass_after = mass_after / hru(j)%area_ha !kg/ha hsaltb_d(j)%salt(1)%diss = mass_after - mass_before -101 format(i8,i8,i8,i8,50(e13.4)) +!*** tu Wunused-label: 101 format(i8,i8,i8,i8,50(e13.4)) return end diff --git a/src/salt_chem_soil_single.f90 b/src/salt_chem_soil_single.f90 index a578c97..a52ed13 100644 --- a/src/salt_chem_soil_single.f90 +++ b/src/salt_chem_soil_single.f90 @@ -112,29 +112,29 @@ subroutine salt_chem_soil_single(hru_num,lay_num,waterC) !rtb salt if(K_ADJ1.gt.0.) then salt_K1 = Ksp11/K_ADJ1 - else + else salt_K1 = 0. - endif + endif if(K_ADJ2.gt.0.) then salt_K2 = Ksp21/K_ADJ2 - else + else salt_K2 = 0. - endif + endif if(K_ADJ3.gt.0.) then salt_K3 = Ksp31/K_ADJ3 - else + else salt_K3 = 0. - endif + endif if(K_ADJ4.gt.0.) then salt_K4 = Ksp41/K_ADJ4 - else + else salt_K4 = 0. - endif + endif if(K_ADJ5.gt.0.) then salt_K5 = Ksp51/K_ADJ5 - else + else salt_K5 = 0. - endif + endif errorTotal = 1 diff --git a/src/sd_channel_control.f90 b/src/sd_channel_control.f90 index 974b763..ba30c3b 100644 --- a/src/sd_channel_control.f90 +++ b/src/sd_channel_control.f90 @@ -44,8 +44,10 @@ subroutine sd_channel_control real :: washld = 0. !tons |wash load real :: bedld = 0. !tons |bed load real :: dep = 0. !tons |deposition - real :: hc_sed = 0. !tons |headcut erosion - real :: chside = 0. !none |change in horizontal distance per unit + real :: sedp_dep = 0. !kg |Particulate P deposition MJW + real :: orgn_dep = 0. !kg |Particulate N deposition MJW + real :: hc_sed !tons |headcut erosion + real :: chside !none |change in horizontal distance per unit ! |change in vertical distance on channel side ! |slopes; always set to 2 (slope=1/2) real :: a = 0. !m^2 |cross-sectional area of channel @@ -232,7 +234,7 @@ subroutine sd_channel_control if(bsn_cc%gwflow.eq.1) then flood_freq(ich) = 1 !flag to indicate the water is in the floodplain call gwflow_fpln(ich) - endif + endif sd_ch(ich)%overbank = "ob" rcharea = sd_ch_vel(ich)%area @@ -413,7 +415,7 @@ subroutine sd_channel_control !! Peters latest channel erosion model !!vel = 1.37 * (sd_ch(ich)%chs ** 0.31) * (12. * sd_ch(ich)%chw) ** 0.32 !annual ave for SWIFT !! mean daily to peak ratio developed from GARDAY - THE STUDY OF MOST PROBABLE MEAN DAILY BANKFULL RUNOFF VOLUMES - !! IN SMALL WATERSHEDS DOMINATED BY CONVECTIVE/FRONTAL CHANNEL FORMING EVENTS AND THE CO-INCIDENT INNER BERM CHANNELS � PART I. + !! IN SMALL WATERSHEDS DOMINATED BY CONVECTIVE/FRONTAL CHANNEL FORMING EVENTS AND THE CO-INCIDENT INNER BERM CHANNELS – PART I. !! Another eq from Peter - Qmax=Qmean*(1+2.66*Drainage Area^-.3) pk_rto = 0.2 + 0.5 / 250. * ob(icmd)%area_ha pk_rto = amin1 (1., pk_rto) @@ -473,7 +475,7 @@ subroutine sd_channel_control shear_btm = 9800. * rcurv%dep * sd_ch(ich)%chs !! Pa = N/m^2 * m * m/m !! if bottom shear > d50 -> downcut - widen to maintain width depth ratio if (shear_btm > shear_btm_cr) then - ebtm_m = sd_ch(ich)%cherod * (shear_btm - shear_btm_cr) !! cm = hr * cm/hr/Pa * Pa + !ebtm_m = sd_ch(ich)%cherod * (shear_btm - shear_btm_cr) !! cm = hr * cm/hr/Pa * Pa !! calc mass of sediment eroded -> t = cm * m/100cm * width (m) * length (km) * 1000 m/km * bd (t/m3) ebtm_t = 10. * ebtm_m * sd_ch(ich)%chw * sd_ch(ich)%chl * sd_ch(ich)%ch_bd end if @@ -490,7 +492,10 @@ subroutine sd_channel_control !sd_ch(ich)%bankfull_flo = 1.0 !***jga bf_flow = sd_ch(ich)%bankfull_flo * ch_rcurv(ich)%elev(2)%flo_rate if (peakrate > bf_flow) then - dep = sd_ch(ich)%chseq * ht1%sed !((peakrate - bf_flow) / peakrate) * ht1%sed + !dep = sd_ch(ich)%chseq * ht1%sed !((peakrate - bf_flow) / peakrate) * ht1%sed + !! deposit Particulate P and N in the floodplain + !sedp_dep = sd_ch(ich)%chseq * ht1%sedp !MJW 2024 May need to include a enrichment factor for transported sediment + !orgn_dep = sd_ch(ich)%chseq * ht1%orgn !MJW 2024 end if !! compute sediment leaving the channel - washload only @@ -537,10 +542,13 @@ subroutine sd_channel_control !! reset sed to tons ht2%sed = sedout - !! add nutrients from bank erosion - t *ppm (1/1,000,000) * 1000. kg/t - ht2%orgn = ht2%orgn + ebank_t * sd_ch(ich)%n_conc * 1000. - ht2%sedp = ht2%sedp + ebank_t * sd_ch(ich)%p_conc * 1000. - ht2%solp = ht2%solp + ebank_t * sd_ch(ich)%p_bio * 1000. + !! subtract nutrients deposited in floodplain + ht2%sedp = ht2%sedp - sedp_dep !MJW 2024 + ht2%orgn = ht2%orgn - orgn_dep !MJW 2024 + !! add nutrients from bank erosion - t * mg/kg (ppm) * kg/1000 mg * 1000 kg/t = kg + ht2%orgn = ht2%orgn + ebank_t * sd_ch(ich)%n_conc + ht2%sedp = ht2%sedp + ebank_t * sd_ch(ich)%p_conc + ht2%solp = ht2%solp + ebank_t * sd_ch(ich)%p_bio !! route constituents call ch_rtpest diff --git a/src/sd_channel_control3.f90 b/src/sd_channel_control3.f90 index ca119e3..68faffd 100644 --- a/src/sd_channel_control3.f90 +++ b/src/sd_channel_control3.f90 @@ -40,7 +40,7 @@ subroutine sd_channel_control3 real :: erode_bank_cut = 0. !cm |widening caused by downcutting (both sides) real :: ebtm_t = 0. !tons |bottom erosion real :: ebank_t = 0. !tons |bank erosion - real :: sedout = 0. !mg |sediment out of waterway channel + real :: sedout = 0. !mg |sediment out of waterway channel real :: washld = 0. !tons |wash load real :: bedld = 0. !tons |bed load real :: dep = 0. !tons |deposition @@ -310,7 +310,9 @@ subroutine sd_channel_control3 end if ! ht1%flo > 0. !rtb hydrograph separation - if (rttime > det) then ! ht1 = incoming + storage + if (rttime > time%dtm / 60.) then ! travel time > routing time step (hours) + !! Variable Storage Coefficent method - sc=2*dt/(2*ttime+dt) - ttime=(in2+out1)/2 + scoef = 24. / (ch_rcurv(jrch)%in2%ttime + ch_rcurv(jrch)%out1%ttime + 24.) !! travel time > timestep -- then all incoming is stored and frac of stored is routed hdsep2%flo_surq = scoef * ch_stor_hdsep(ich)%flo_surq hdsep2%flo_latq = scoef * ch_stor_hdsep(ich)%flo_latq diff --git a/src/sd_channel_module.f90 b/src/sd_channel_module.f90 index 9662066..d6bd53d 100644 --- a/src/sd_channel_module.f90 +++ b/src/sd_channel_module.f90 @@ -24,10 +24,10 @@ module sd_channel_module real :: chl = 0. !km |channel length real :: chn = 0. ! |channel Manning's n real :: chk = 0. !mm/h |channel bottom conductivity - real :: cherod = 0. ! |channel erodibility + real :: bank_exp = 0. ! |bank erosion exponent real :: cov = 0. !0-1 |channel cover factor real :: sinu = 0. !none |sinuousity - ratio of channel length and straight line length - real :: chseq = 0. !m/m |equilibrium channel slope + real :: vcr_coef = 0. ! |critical velocity coefficient real :: d50 = 0. !mm |channel median sediment size real :: ch_clay = 0. !% |clay percent of bank and bed real :: carbon = 0. !% |carbon percent of bank and bed @@ -54,7 +54,7 @@ module sd_channel_module real :: n_dep_enr = 0.5 ! |enrichment of N in remaining water - deposition = 1/enrichment ratio real :: p_dep_enr = 0.5 ! |enrichment of P in remaining water - deposition = 1/enrichment ratio real :: arc_len_fr = 1.2 !frac |fraction of arc length where bank erosion occurs - real :: part_size = 0.002 !mm |particle size of channel washload + real :: bed_exp = 1.5 ! |bed erosion exponential coefficient real :: wash_bed_fr = 0.1 !frac |fraction of bank erosion that is washload end type swatdeg_sednut_data type (swatdeg_sednut_data), dimension (:), allocatable :: sd_chd1 @@ -172,7 +172,7 @@ module sd_channel_module real :: chk = 0. !mm/h |channel bottom conductivity real :: cov = 0. !0-1 |channel cover factor real :: sinu = 0. !none |sinuousity - ratio of channel length and straight line length - real :: chseq = 0. !m/m |equilibrium channel slope + real :: vcr_coef = 0. !m/m |critical velocity coefficient real :: d50 = 0. real :: ch_clay = 0. real :: carbon = 0. @@ -193,12 +193,12 @@ module sd_channel_module real :: n_dep_enr = 0.5 ! |enrichment of N in remaining water - deposition = 1/enrichment ratio real :: p_dep_enr = 0.5 ! |enrichment of P in remaining water - deposition = 1/enrichment ratio real :: arc_len_fr = 1.2 !frac |fraction of arc length where bank erosion occurs - real :: part_size = 0.002 !mm |particle size of channel washload + real :: bed_exp = 1.5 !mm |bed erosion exponent real :: wash_bed_fr = 0.2 !frac |fraction of bank erosion that is washload real :: hc_kh = 0. real :: hc_hgt = 0. !m |headcut height real :: hc_ini = 0. - real :: cherod = 0. ! |channel erodibility + real :: bank_exp = 0. ! |bank erosion exponent real :: shear_bnk = 0. !0-1 |bank shear coefficient - fraction of bottom shear real :: hc_erod = 0. ! |headcut erodibility real :: hc_co = 0. !m/m |proportionality coefficient for head cut diff --git a/src/sd_channel_sediment.f90 b/src/sd_channel_sediment.f90 index ed7048c..233cc5b 100644 --- a/src/sd_channel_sediment.f90 +++ b/src/sd_channel_sediment.f90 @@ -115,7 +115,7 @@ subroutine sd_channel_sediment (ts_int) shear_bank_cr = 0.493 * 10. ** (.0182 * sd_ch(ich)%ch_clay) e_bank = 0. if (shear_bank_adj > shear_bank_cr) then - e_bank = ts_hr * sd_ch(ich)%cherod * (shear_bank_adj - shear_bank_cr) !! cm = hr * cm/hr/Pa * Pa + !e_bank = ts_hr * sd_ch(ich)%cherod * (shear_bank_adj - shear_bank_cr) !! cm = hr * cm/hr/Pa * Pa erode_bank = erode_bank + e_bank !! calc mass of sediment eroded -> t = cm * m/100cm * width (m) * length (km) * 1000 m/km * bd (t/m3) !! apply to only one side (perim_bank / 2.) @@ -128,7 +128,7 @@ subroutine sd_channel_sediment (ts_int) if (sd_ch(ich)%chs > 0.000001) then ! sd_ch(ich)%chseq) then !! if bottom shear > d50 -> downcut - widen to maintain width depth ratio if (shear_btm > shear_btm_cr) then - e_btm = ts_hr * sd_ch(ich)%cherod * (shear_btm - shear_btm_cr) !! cm = hr * cm/hr/Pa * Pa + !e_btm = ts_hr * sd_ch(ich)%cherod * (shear_btm - shear_btm_cr) !! cm = hr * cm/hr/Pa * Pa !! if downcutting - check width depth ratio to see if widens !if (sd_ch(ich)%chw / sd_ch(ich)%chd < sd_ch(ich)%wd_rto) then ! erode_bank_cut = e_btm * sd_ch(ich)%wd_rto @@ -165,7 +165,7 @@ subroutine sd_channel_sediment (ts_int) !! compute flood plain deposition bf_flow = sd_ch(ich)%bankfull_flo * ch_rcurv(ich)%elev(2)%flo_rate if (peakrate > bf_flow) then - dep = sd_ch(ich)%chseq * ht1%sed !((peakrate - bf_flow) / peakrate) * ht1%sed + !dep = sd_ch(ich)%chseq * ht1%sed !((peakrate - bf_flow) / peakrate) * ht1%sed end if !! output channel morphology @@ -187,7 +187,7 @@ subroutine sd_channel_sediment (ts_int) chsd_d(ich)%hc_m = hc !! compute sediment leaving the channel - washload only - bottom deg is bedload - sedout = ht1%sed - dep + hc_sed + erode_bank ! + ebtm_t + sedout = ht1%sed - dep + hc_sed + erode_bank ! + ebtm_t ht2%sed = sedout diff --git a/src/sd_channel_sediment3.f90 b/src/sd_channel_sediment3.f90 index a6ea481..e94d4ad 100644 --- a/src/sd_channel_sediment3.f90 +++ b/src/sd_channel_sediment3.f90 @@ -2,6 +2,7 @@ subroutine sd_channel_sediment3 use climate_module use sd_channel_module + use channel_module use hydrograph_module use time_module use hru_module, only : hru @@ -22,18 +23,20 @@ subroutine sd_channel_sediment3 real :: vel_fall = 0. !m/s |fall velocity of sediment particles in channel real :: dep_fall = 0. !m |fall depth of sediment particles in channel real :: del_rto = 0. !frac |fraction of sediment deposited in channel - real :: conc_chng = 0. ! |change in concentration (and mass) in channel sol and org N and P real :: ebtm_m = 0. !m |erosion of bottom of channel real :: ebank_m = 0. !m |meander cut on one side real :: ebtm_t = 0. !tons |bottom erosion real :: ebank_t = 0. !tons |bank erosion real :: shear_btm_cr = 0. ! | real :: shear_btm = 0. ! | + real :: inflo = 0. !m^3 |inflow water volume + real :: inflo_rate = 0. !m^3/s |inflow rate + real :: flo_time = 0. !s |estimate of total flow time through the channel real :: bf_flow = 0. !m3/s |bankfull flow rate * adjustment factor real :: pk_rto = 0. !ratio |peak to mean flow rate ratio real :: bd_fac = 0. ! |bulk density factor for critical velocity calculation real :: cohes_fac = 0. ! |cohesion factor for critical velocity calculation - !real :: qman !m^3/s or m/s |flow rate or flow velocity + real :: florate !m^3/s |flow rate below the triangle for flow lasting more than a day real :: vel = 0. real :: veg = 0. real :: vel_cr = 0. @@ -49,7 +52,7 @@ subroutine sd_channel_sediment3 real :: precip = 0. real :: flovol_ob = 0. real :: wet_fill = 0. - + ich = isdch iob = sp_ob1%chandeg + jrch - 1 @@ -67,35 +70,16 @@ subroutine sd_channel_sediment3 !! calculate channel sed and nutrient processes if inflow > 0 if (ht1%flo > 1.e-6) then - !! Another eq from Peter - Qmax=Qmean*(1+2.66*Drainage Area^-.3) - pk_rto = 0.2 + 0.5 / 250. * ob(icmd)%area_ha - pk_rto = Max (1., pk_rto) - pk_rto = 1. + 2.66 * (ob(icmd)%area_ha / 100.) ** (-.3) - !pk_rto = 1. + 1.33 * (ob(icmd)%area_ha / 100.) ** (-.3) - !pk_rto = 1. + 2. * (ob(icmd)%area_ha / 100.) ** (-.3) - !pk_rto = Min (2., pk_rto) - !pk_rto = 1.5 - peakrate = pk_rto * ht1%flo / 86400. !m3/s + !! calculate peak daily flow + peakrate = sd_ch(ich)%pk_rto * ht1%flo / 86400. !m3/s !! interpolate rating curve using peak rate call rcurv_interp_flo (ich, peakrate) !! use peakrate as flow rate h_rad = rcurv%xsec_area / rcurv%wet_perim - sd_ch(ich)%chn = 0.39 * sd_ch(ich)%chs ** 0.38 * h_rad ** (-0.16) - sd_ch(ich)%chn = 0.5 + 0.2 * (ob(icmd)%area_ha / 100.) ** (-.3) - if (ob(icmd)%area_ha <= 5.) then - sd_ch(ich)%chn = 0.13 - end if - if (ob(icmd)%area_ha >= 2500.) then - sd_ch(ich)%chn = 0.03 - end if - if (ob(icmd)%area_ha > 5. .and. ob(icmd)%area_ha >= 2500.) then - sd_ch(ich)%chn = 0.2 / log(ob(icmd)%area_ha / 100.) - end if - sd_ch(ich)%chn = Min (0.15, sd_ch(ich)%chn) - sd_ch(ich)%chn = Max (0.02, sd_ch(ich)%chn) vel = h_rad ** .6666 * Sqrt(sd_ch(ich)%chs) / (sd_ch(ich)%chn + .001) !vel = peakrate / rcurv%xsec_area + rttime = sd_ch(ich)%chl / (3.6 * vel) !! add precip to inflow - km * m * 1000 m/km * ha/10000 m2 = ha ch_wat_d(ich)%area_ha = sd_ch(ich)%chl * sd_ch(ich)%chw / 10. @@ -107,14 +91,24 @@ subroutine sd_channel_sediment3 ht1%flo = ht1%flo + precip !! compute flood plain deposition + !sd_ch(ich)%bankfull_flo = 2. bf_flow = sd_ch(ich)%bankfull_flo * ch_rcurv(ich)%elev(2)%flo_rate florate_ob = peakrate - bf_flow - flovol_ob = florate_ob * 86400. - flovol_ob = Min (flovol_ob, ht1%flo) - if (flovol_ob > 0.) then - trap_eff = 0.05 * log(sd_ch(ich)%fp_inun_days) + 0.1 + if (florate_ob > 0.) then + flo_time = 2. * ht1%flo / peakrate + !! assume a triangular distribution + if (flo_time < 86400.) then + !! flow is over within the day + flovol_ob = ht1%flo * (((peakrate - bf_flow) / peakrate) ** 2) + else + !! flow continues over the day - florate is the rate under the triangle + florate = 2. * ht1%flo - peakrate + flovol_ob = ht1%flo * (((peakrate - bf_flow) / (peakrate - florate)) ** 2) + end if + !trap_eff = 0.05 * log(sd_ch(ich)%fp_inun_days) + 0.1 + !! trap efficiency from Dynamic SedNet Component Model Reference Guide: Update 2017 fp_m2 = 3. * sd_ch(ich)%chw * sd_ch(ich)%chl * 1000. - exp_co = 0.00001 * fp_m2 / florate_ob + exp_co = 0.0007 * fp_m2 / florate_ob trap_eff = sd_ch(ich)%fp_inun_days * (florate_ob / peakrate) * (1. - exp(-exp_co)) trap_eff = Min (1., trap_eff) fp_dep%sed = trap_eff * ht1%sed @@ -123,8 +117,8 @@ subroutine sd_channel_sediment3 fp_dep%orgn = trap_eff * sd_ch(ich)%n_dep_enr * ht1%orgn fp_dep%sedp = trap_eff * sd_ch(ich)%p_dep_enr * ht1%sedp !! trap nitrate and sol P in flood plain - when not simulating flood plain interactions? - fp_dep%no3 = trap_eff * ht1%no3 - fp_dep%solp = trap_eff * ht1%solp + fp_dep%no3 = 0. !trap_eff * ht1%no3 + fp_dep%solp = 0. !trap_eff * ht1%solp ht1 = ht1 - fp_dep !! if flood plain link - fill wetlands to emergency @@ -144,6 +138,7 @@ subroutine sd_channel_sediment3 rto = Min (1., rto) if (rto > 1.e-6) then wet(iihru) = wet(iihru) + rto * ht1 + wet_in_d(iihru) = wet_in_d(iihru) + rto * ht1 hru(iihru)%wet_obank_in = (rto * ht1%flo) / (10. * hru(iihru)%area_ha) rto1 = 1. - rto ob(icmd)%tsin(:) = rto1 * ob(icmd)%tsin(:) @@ -156,25 +151,7 @@ subroutine sd_channel_sediment3 !! add sediment deposition to calculate mm of deposition over the flood plain later ch_morph(ich)%fp_mm = ch_morph(ich)%fp_mm + fp_dep%sed - - !! calculate channel deposition based on fall velocity - SWRRB book - !! assume particle size = 0.03 mm -- median silt size - vel_fall = 411. * sd_ch(ich)%part_size ** 2 ! m/h - dep_fall = vel_fall * rcurv%ttime - !! assume bankfull flow depth - if (dep_fall < sd_ch(ich)%chd) then - del_rto = 1. - .5 * dep_fall / sd_ch(ich)%chd - else - del_rto = .5 * sd_ch(ich)%chd / dep_fall - end if - ch_dep%sed = (1. - del_rto) * ht1%sed - ch_dep%orgn = sd_ch(ich)%n_dep_enr * (1. - del_rto) * ht1%orgn - ch_dep%sedp = sd_ch(ich)%p_dep_enr * (1. - del_rto) * ht1%sedp - rto = ch_dep%flo / ht1%flo - ob(icmd)%tsin(:) = (1. - rto) * ob(icmd)%tsin(:) - ht1 = ht1 - ch_dep - !! calc bank erosion cohesion = (-87.1 + (42.82 * sd_ch(ich)%ch_clay) - (0.261 * sd_ch(ich)%ch_clay ** 2.) & + (0.029 * sd_ch(ich)%ch_clay ** 3.)) @@ -183,64 +160,73 @@ subroutine sd_channel_sediment3 bd_fac = Max (0.001, 0.03924 * sd_ch(ich)%ch_bd * 1000. - 1000.) cohes_fac = 0.021 * cohesion + veg vel_cr = log10 (2200. * sd_ch(ich)%chd) * (0.0004 * (bd_fac + cohes_fac)) ** 0.5 - - !cohesion = (15. / (15.3 - 0.438 * sd_ch(ich)%ch_clay + 0.0044 * sd_ch(ich)%ch_clay ** 2.)) * 1000. - !veg = exp (-5. * sd_ch(ich)%chd) * cha1(icha)%dat%cov !function of cover factor - !vel_cr = log10 (8.8 * sd_ch(ich)%chd / 0.004) * (0.0004 * ((sd_ch(ich)%ch_bd * & - ! 1000. - 1000.) * 9.81 * 0.004 + 0.021 * cohesion + veg)) ** 0.5 + !sd_ch(ich)%vcr_coef = 1. + vel_cr = sd_ch(ich)%vcr_coef * vel_cr !! calculate radius of curvature - rad_curv = ((12. * sd_ch(ich)%chw) * sd_ch(ich)%sinu ** 1.5) / (13. * (sd_ch(ich)%sinu -1.) ** 0.5) + rad_curv = ((12. * sd_ch(ich)%chw) * sd_ch(ich)%sinu ** 1.5) / & + (13. * (sd_ch(ich)%sinu -1.) ** 0.5) vel_bend = vel * (1. / rad_curv + 1.) vel_rch = 0.33 * vel_bend + 0.66 * vel b_exp = 12.3 / sqrt (sd_ch(ich)%ch_clay + 1.) b_exp = min (3.5, b_exp) - if (vel_rch > vel_cr) then ! .and. rcurv%dep / sd_ch(ich)%chd > 0.1) then - ebank_m = 0.0024 * (vel_rch / vel_cr) ** b_exp !bank erosion m/yr + !sd_ch(ich)%bank_exp = 2. + if (vel_rch > vel_cr) then + !! bank erosion m/yr + ebank_m = 0.0024 * (vel_rch / vel_cr) ** sd_ch(ich)%bank_exp else ebank_m = 0. end if ch_morph(ich)%w_yr = ch_morph(ich)%w_yr + ebank_m !! calc mass of sediment eroded -> t = bankcut (m) * depth (m) * lengthcut (m) * bd (t/m3) - !! arc length = 0.33 * meander wavelength * sinuosity -> protected length - arc_len = 0.33 * (12. * sd_ch(ich)%chw) * sd_ch(ich)%sinu + !! arc length = 0.33 * meander wavelength * sinuosity + arc_len = 0.66 * (12. * sd_ch(ich)%chw) * sd_ch(ich)%sinu prot_len = arc_len * sd_ch(ich)%arc_len_fr - prot_len = 0.2 * sd_ch(ich)%chl * 1000. - !rad_curv = (12. * sd_ch(ich)%chw * sd_ch(ich)%sinu ** 1.5) / & - ! (13. * (sd_ch(ich)%sinu - 0.999) ** 0.5) - !cutbank_adj = 2.57 - 0.36 * log(rad_curv / sd_ch(ich)%chw) - !ebank_t = ebank_m * sd_ch(ich)%chd * sd_ch(ich)%arc_len_fr * prot_len * sd_ch(ich)%ch_bd - !ebank_t = 0.8 * ebank_t !assume 80% wash load and 20% bed deposition - !ebank_t = max (0., ebank_t) - !ebank_t = 1000. * (vel_rch * sd_ch(ich)%chs) ** 2. * (1. - sd_ch(ich)%cov) * (sd_ch(ich)%ch_clay + 1.) - !sd_ch(ich)%pk_rto = 500. - ebank_t = (1000. * sd_ch(ich)%pk_rto * vel_rch * sd_ch(ich)%chs) ** 2. * & - (1. - sd_ch(ich)%ch_clay / 100.) - prot_len = 0.2 * sd_ch(ich)%chl - ebank_t = ebank_t * prot_len + ebank_t = ebank_m * sd_ch(ich)%chd * sd_ch(ich)%arc_len_fr * prot_len * sd_ch(ich)%ch_bd bank_ero%sed = ebank_t !! calculate associated nutrients - bank_ero%orgn = bank_ero%sed * sd_ch(ich)%n_conc - bank_ero%sedp = (1. - sd_ch(ich)%p_bio) * bank_ero%sed * sd_ch(ich)%p_conc + bank_ero%orgn = bank_ero%sed * sd_ch(ich)%n_conc / 1000. + bank_ero%sedp = (1. - sd_ch(ich)%p_bio) * bank_ero%sed * sd_ch(ich)%p_conc / 1000. bank_ero%no3 = 0. - bank_ero%solp = sd_ch(ich)%p_bio * bank_ero%sed * sd_ch(ich)%p_conc + bank_ero%solp = sd_ch(ich)%p_bio * bank_ero%sed * sd_ch(ich)%p_conc / 1000. bank_ero%no2 = 0. rto = bank_ero%flo / ht1%flo ob(icmd)%tsin(:) = (1. - rto) * ob(icmd)%tsin(:) ht1 = ht1 + bank_ero + !! calculate channel deposition based on fall velocity - SWRRB book + !! assume particle size = 0.03 mm -- median silt size + !vel_fall = 411. * sd_ch(ich)%part_size ** 2 ! m/h + !dep_fall = vel_fall * rcurv%ttime + !! assume bankfull flow depth + !if (dep_fall < sd_ch(ich)%chd) then + ! del_rto = 1. - .5 * dep_fall / sd_ch(ich)%chd + !else + ! del_rto = .5 * sd_ch(ich)%chd / dep_fall + !end if + !ch_dep%sed = (1. - del_rto) * ht1%sed + !ch_dep%orgn = sd_ch(ich)%n_dep_enr * (1. - del_rto) * ht1%orgn + !ch_dep%sedp = sd_ch(ich)%p_dep_enr * (1. - del_rto) * ht1%sedp + !rto = ch_dep%flo / ht1%flo + !ob(icmd)%tsin(:) = (1. - rto) * ob(icmd)%tsin(:) + !ht1 = ht1 - ch_dep + !! calculate channel deposition as the bedload fraction of bank erosion + ch_dep%sed = sd_ch(ich)%wash_bed_fr * bank_ero%sed + ch_dep%orgn = sd_ch(ich)%n_dep_enr * sd_ch(ich)%wash_bed_fr * bank_ero%orgn + ch_dep%sedp = sd_ch(ich)%p_dep_enr * sd_ch(ich)%wash_bed_fr * bank_ero%sedp + ht1 = ht1 - ch_dep !! calculate bed erosion !! no downcutting below equilibrium slope - if (sd_ch(ich)%chs > 0.000001) then !sd_ch(ich)%chseq) then + if (sd_ch(ich)%chs > 0.000001) then !! calc critical shear and shear on bottom of channel shear_btm_cr = sd_ch(ich)%d50 shear_btm = 9800. * rcurv%dep * sd_ch(ich)%chs !! Pa = N/m^2 * m * m/m !! critical shear function of d50 vel_cr = 0.293 * (sd_ch(ich)%d50) ** 0.5 - vel_cr = 1. if (vel > vel_cr) then - ebtm_m = 0.0001 * (vel_rch / vel_cr) ** 1.5 !bed erosion m/yr + !! bed erosion m/yr + ebtm_m = 0.0001 * (vel_rch / vel_cr) ** sd_ch(ich)%bed_exp end if !! calc mass of sediment eroded -> t = m * width (m) * length (km) * 1000 m/km * bd (t/m3) ebtm_t = 1000. * ebtm_m * sd_ch(ich)%chw * sd_ch(ich)%chl * sd_ch(ich)%ch_bd @@ -255,8 +241,8 @@ subroutine sd_channel_sediment3 bed_ero%solp = sd_ch(ich)%p_bio * bed_ero%sed * sd_ch(ich)%p_conc bed_ero%no2 = 0. rto = bed_ero%flo / ht1%flo - ob(icmd)%tsin(:) = (1. - rto) * ob(icmd)%tsin(:) - ht1 = ht1 + bed_ero + !ob(icmd)%tsin(:) = (1. - rto) * ob(icmd)%tsin(:) + !ht1 = ht1 + bed_ero end if ! inflow>0 diff --git a/src/sd_hydsed_init.f90 b/src/sd_hydsed_init.f90 index 9bc7cff..5832299 100644 --- a/src/sd_hydsed_init.f90 +++ b/src/sd_hydsed_init.f90 @@ -79,12 +79,11 @@ subroutine sd_hydsed_init sd_ch(i)%chn = sd_chd(idb)%chn if (sd_ch(i)%chn < .05) sd_ch(i)%chn = .05 !***jga sd_ch(i)%chk = sd_chd(idb)%chk - sd_ch(i)%cherod = sd_chd(idb)%cherod + sd_ch(i)%bank_exp = sd_chd(idb)%bank_exp sd_ch(i)%cov = sd_chd(idb)%cov sd_ch(i)%sinu = sd_chd(idb)%sinu if (sd_ch(i)%sinu < 1.05) sd_ch(i)%sinu = 1.05 - sd_ch(i)%chseq = sd_chd(idb)%chseq - if (sd_ch(i)%chseq < 1.e-6) sd_ch(i)%chseq = 0.5 + sd_ch(i)%vcr_coef = sd_chd(idb)%vcr_coef sd_ch(i)%d50 = sd_chd(idb)%d50 sd_ch(i)%ch_clay = sd_chd(idb)%ch_clay sd_ch(i)%carbon = sd_chd(idb)%carbon @@ -111,7 +110,7 @@ subroutine sd_hydsed_init sd_ch(i)%n_dep_enr = sd_chd1(idb1)%n_dep_enr sd_ch(i)%p_dep_enr = sd_chd1(idb1)%p_dep_enr sd_ch(i)%arc_len_fr = sd_chd1(idb1)%arc_len_fr - sd_ch(i)%part_size = sd_chd1(idb1)%part_size + sd_ch(i)%bed_exp = sd_chd1(idb1)%bed_exp sd_ch(i)%wash_bed_fr = sd_chd1(idb1)%wash_bed_fr !! compute headcut parameters @@ -165,8 +164,8 @@ subroutine sd_hydsed_init end do !! Compute storage time constant for reach (msk_co1 + msk_co2 = 1.) - msk1 = bsn_prm%msk_co1 / (bsn_prm%msk_co1 + bsn_prm%msk_co2) - msk2 = bsn_prm%msk_co2 / (bsn_prm%msk_co1 + bsn_prm%msk_co2) + msk1 = bsn_prm%msk_co1 / (bsn_prm%msk_co1 + bsn_prm%msk_co2) + msk2 = bsn_prm%msk_co2 / (bsn_prm%msk_co1 + bsn_prm%msk_co2) xkm = sd_ch(i)%stor_dis_bf * msk1 + sd_ch(i)%stor_dis_01bf * msk2 !! Muskingum numerical stability -Jaehak Jeong, 2011 @@ -305,7 +304,7 @@ subroutine sd_hydsed_init ch_water(ich)%cs(ics) = (cs_cha_ini(ics_ini)%conc(ics)/1000.) * tot_stor(ich)%flo !kg enddo enddo - endif + endif return end subroutine sd_hydsed_init \ No newline at end of file diff --git a/src/sep_biozone.f90 b/src/sep_biozone.f90 index 7a299f4..4fd91fa 100644 --- a/src/sep_biozone.f90 +++ b/src/sep_biozone.f90 @@ -1,5 +1,5 @@ subroutine sep_biozone - + !! ~ ~ ~ PURPOSE ~ ~ ~ !! This subroutine conducts biophysical processes occuring !! in the biozone layer of a septic HRU. @@ -45,18 +45,18 @@ subroutine sep_biozone use soil_module use time_module - implicit none + implicit none integer :: bz_lyr = 0 !none |soil layer where biozone exists integer :: isp = 0 !none |type of septic system for current hru integer :: j = 0 !none |hru integer :: nly = 0 ! | - real*8 :: bz_vol = 0.d0 !m^3 |volume of biozone + real*8 :: bz_vol = 0.d0 !m^3 |volume of biozone real*8 :: rtrate = 0.d0 ! | real*8 :: qin = 0.d0 !m^3 H2O |water in reach during time step real*8 :: qout = 0.d0 ! | real*8 :: rplqm = 0.d0 !kg/ha |daily change in plaque - real*8 :: ntr_rt = 0.d0 !1/day |nitrification reaction rate + real*8 :: ntr_rt = 0.d0 !1/day |nitrification reaction rate real*8 :: dentr_rt = 0.d0 !1/day |denitrification reaction rate real*8 :: bod_rt = 0.d0 !1/day |BOD reaction rate real*8 :: fcoli_rt = 0.d0 !1/day |fecal coliform reaction rate @@ -68,30 +68,30 @@ subroutine sep_biozone ! |value needed in later equations real*8 :: bodi = 0.d0 ! | real*8 :: bode = 0.d0 ! | - real*8 :: rnit = 0.d0 !kg/ha |nitrification during the day + real*8 :: rnit = 0.d0 !kg/ha |nitrification during the day real*8 :: rdenit = 0.d0 !kg/ha |denitrification during the day real*8 :: rmort = 0.d0 !kg/ha |daily mortality of bacteria real*8 :: rrsp = 0.d0 !kg/ha |daily resparation of bacteria real*8 :: rslg = 0.d0 !kg/ha |daily slough-off bacteria real*8 :: rbod = 0.d0 !mg/l |daily change in bod concentration real*8 :: rfcoli = 0.d0 !cfu/100ml |daily change in fecal coliform - real*8 :: nh3_begin = 0.d0 ! | + real*8 :: nh3_begin = 0.d0 ! | real*8 :: nh3_end = 0.d0 ! | real*8 :: nh3_inflw_ste = 0.d0! | real*8 :: no3_begin = 0.d0 ! | real*8 :: no3_end = 0.d0 ! | - real*8 :: no3_inflow_ste = 0.d0! | + real*8 :: no3_inflow_ste = 0.d0! | real*8 :: bza = 0.d0 ! | real*8 :: qi = 0.d0 ! | real*8 :: nperc = 0.d0 ! | - real*8 :: nh3_init = 0.d0 ! | + real*8 :: nh3_init = 0.d0 ! | real*8 :: no3_init = 0.d0 ! | real*8 :: hvol = 0.d0 ! | real*8 :: solpconc = 0.d0 ! | real*8 :: solpsorb = 0.d0 ! | real*8 :: qlyr = 0.d0 ! | real*8 :: qsrf = 0.d0 ! | - real*8 :: solp_init = 0.d0 ! | + real*8 :: solp_init = 0.d0 ! | real*8 :: solp_begin = 0.d0 ! | real*8 :: solp_end = 0.d0 ! | real*8 :: svolp = 0.d0 ! | @@ -99,75 +99,75 @@ subroutine sep_biozone real*8 :: ctmp = 0.d0 ! | real*8 :: percp = 0.d0 ! | - j = ihru - nly = soil(j)%nly + j = ihru + nly = soil(j)%nly isep = iseptic(j) - isp = sep(isep)%typ !! J.Jeong 3/09/09 + isp = sep(isep)%typ !! J.Jeong 3/09/09 bz_lyr = i_sep(j) - bza = hru(j)%area_ha - bz_vol = sep(isep)%thk * bza * 10. !m^3 - qlyr = qstemm(j) - qsrf = 0 - - !temperature correction factor for bacteria growth/dieoff (Eppley, 1972) + bza = hru(j)%area_ha + bz_vol = sep(isep)%thk * bza * 10. !m^3 + qlyr = qstemm(j) + qsrf = 0 + + !temperature correction factor for bacteria growth/dieoff (Eppley, 1972) !ibac = 1 !there should be a loop for all pathogens in this hru - !ctmp = path_db(ibac)%t_adj ** (soil(j)%phys(bz_lyr)%tmp- 20.) + !ctmp = path_db(ibac)%t_adj ** (soil(j)%phys(bz_lyr)%tmp- 20.) ctmp = 1. - ! initial water volume - qi = (soil(j)%phys(bz_lyr)%st + soil(j)%ly(bz_lyr-1)%prk + qstemm(j)) * & + ! initial water volume + qi = (soil(j)%phys(bz_lyr)%st + soil(j)%ly(bz_lyr-1)%prk + qstemm(j)) * & bza * 10. !m3 ! STE volume - qin = qstemm(j) * bza * 10. ! m^3 - ! leaching to septic layer - qout = bz_perc(j) * bza * 10. !m3/d - ! final volume - hvol = soil(j)%phys(bz_lyr)%st * bza * 10. - rtof = 0.5 + qin = qstemm(j) * bza * 10. ! m^3 + ! leaching to septic layer + qout = bz_perc(j) * bza * 10. !m3/d + ! final volume + hvol = soil(j)%phys(bz_lyr)%st * bza * 10. + rtof = 0.5 - nh3_init = soil1(j)%mn(bz_lyr)%nh4 - no3_init = soil1(j)%mn(bz_lyr)%no3 - solp_init = soil1(j)%mp(bz_lyr)%lab + nh3_init = soil1(j)%mn(bz_lyr)%nh4 + no3_init = soil1(j)%mn(bz_lyr)%no3 + solp_init = soil1(j)%mp(bz_lyr)%lab - !! Failing system: STE saturates upper soil layers - if (sep(isep)%opt == 2) then - - ! increment the number of failing days - if(sep_tsincefail(j)>0) sep_tsincefail(j) = sep_tsincefail(j) + 1 + !! Failing system: STE saturates upper soil layers + if (sep(isep)%opt == 2) then + + ! increment the number of failing days + if(sep_tsincefail(j)>0) sep_tsincefail(j) = sep_tsincefail(j) + 1 ! convert the failing system into an active system if duration of failing ends - if (sep_tsincefail(j) >= sep(isep)%tfail) then - sep(isep)%opt = 1 + if (sep_tsincefail(j) >= sep(isep)%tfail) then + sep(isep)%opt = 1 soil(j)%phys(bz_lyr)%ul=sep(isep)%thk * & (soil(j)%phys(bz_lyr)%por - soil(j)%phys(bz_lyr)%wp) soil(j)%phys(bz_lyr)%fc=sep(isep)%thk*(soil(j)%phys(bz_lyr)%up- & soil(j)%phys(bz_lyr)%wp) - soil1(j)%mn(bz_lyr)%nh4 = 0 - soil1(j)%mn(bz_lyr)%no3 = 0 - soil1(j)%hsta(bz_lyr)%n = 0 - soil1(j)%hsta(bz_lyr)%p = 0 - soil1(j)%tot(bz_lyr)%p = 0 - soil1(j)%mp(bz_lyr)%lab = 0 + soil1(j)%mn(bz_lyr)%nh4 = 0 + soil1(j)%mn(bz_lyr)%no3 = 0 + soil1(j)%hsta(bz_lyr)%n = 0 + soil1(j)%hsta(bz_lyr)%p = 0 + soil1(j)%tot(bz_lyr)%p = 0 + soil1(j)%mp(bz_lyr)%lab = 0 soil1(j)%mp(bz_lyr)%act = 0 - biom(j) = 0 + biom(j) = 0 plqm(j) = 0 - bio_bod(j) = 0 - fcoli(j) = 0 - sep_tsincefail(j) = 0 - end if + bio_bod(j) = 0 + fcoli(j) = 0 + sep_tsincefail(j) = 0 + end if - return - endif + return + endif - !! Active system + !! Active system !! Water content(eqn 4-12), biozone hydraulic conductivity(eqn 4-9), - !! and percolation (eqn 4-8,10,11) are computed in percmain/percmicro + !! and percolation (eqn 4-8,10,11) are computed in percmain/percmicro - ! Add STE nutrients to appropriate soil pools in mass unit - xx = qin / bza / 1000. ! used for unit conversion: mg/l -> kg/ha + ! Add STE nutrients to appropriate soil pools in mass unit + xx = qin / bza / 1000. ! used for unit conversion: mg/l -> kg/ha soil1(j)%mn(bz_lyr)%no3 = soil1(j)%mn(bz_lyr)%no3 + xx * & (sepdb(sep(isep)%typ)%no3concs + & sepdb(sep(isep)%typ)%no2concs) @@ -188,93 +188,93 @@ subroutine sep_biozone bodi = bio_bod(j) * bza / qi * 1000. !mg/l - !! Field capacity in the biozone Eq. 4-6 ! + !! Field capacity in the biozone Eq. 4-6 ! soil(j)%phys(bz_lyr)%fc = soil(j)%phys(bz_lyr)%fc + sep(isep)%fc1 & * (soil(j)%phys(bz_lyr)%ul - soil(j)%phys(bz_lyr)%fc) ** & sep(isep)%fc2 * rbiom(j) / (sep(isep)%bd * 10) - !! Saturated water content in the biozone - Eq. 4-7 - ! mm = mm - kg/ha / (kg/m^3 * 10) + !! Saturated water content in the biozone - Eq. 4-7 + ! mm = mm - kg/ha / (kg/m^3 * 10) soil(j)%phys(bz_lyr)%ul = soil(j)%phys(bz_lyr)%por * & sep(isep)%thk-plqm(j) /(sep(isep)%bd*10.) - if(soil(j)%phys(bz_lyr)%ul.le.soil(j)%phys(bz_lyr)%fc) then - soil(j)%phys(bz_lyr)%ul = soil(j)%phys(bz_lyr)%fc - sep(isep)%opt = 2 - endif + if(soil(j)%phys(bz_lyr)%ul.le.soil(j)%phys(bz_lyr)%fc) then + soil(j)%phys(bz_lyr)%ul = soil(j)%phys(bz_lyr)%fc + sep(isep)%opt = 2 + endif - !! Respiration rate(kg/ha) Eq. 4-2 - rrsp = ctmp * sep(isep)%rsp * biom(j) + !! Respiration rate(kg/ha) Eq. 4-2 + rrsp = ctmp * sep(isep)%rsp * biom(j) - !! Mortality rate(kg/ha) Eq. 4-3 - rmort = ctmp * sep(isep)%mrt * biom(j) + !! Mortality rate(kg/ha) Eq. 4-3 + rmort = ctmp * sep(isep)%mrt * biom(j) - !! Slough-off rate(kg/ha) - rslg = sep(isep)%slg1 * bz_perc(j) ** sep(isep)%slg2 * biom(j) - - - !! Build up of plqm(kg/ha) Eq.4-5 - ! kg/ha (perday) = kg/ha + dimensionless * m^3/d * mg/l / (1000*ha) + !! Slough-off rate(kg/ha) + rslg = sep(isep)%slg1 * bz_perc(j) ** sep(isep)%slg2 * biom(j) + + + !! Build up of plqm(kg/ha) Eq.4-5 + ! kg/ha (perday) = kg/ha + dimensionless * m^3/d * mg/l / (1000*ha) rplqm = (rmort - rslg) + sep(isep)%plq * qin * & sepdb(sep(isep)%typ)%tssconcs / (1000. * bza) - rplqm = max(0.,rplqm) + rplqm = max(0.,rplqm) - !! Add build up to plqm ! kg/ha = kg/ha + kg/ha + !! Add build up to plqm ! kg/ha = kg/ha + kg/ha plqm(j) = plqm(j) + rplqm - - nh3_inflw_ste = xx * sepdb(sep(isep)%typ)%nh4concs - no3_inflow_ste = xx*(sepdb(sep(isep)%typ)%no3concs + & + + nh3_inflw_ste = xx * sepdb(sep(isep)%typ)%nh4concs + no3_inflow_ste = xx*(sepdb(sep(isep)%typ)%no3concs + & sepdb(sep(isep)%typ)%no2concs) - nh3_begin = soil1(j)%mn(bz_lyr)%nh4 - no3_begin = soil1(j)%mn(bz_lyr)%no3 - solp_begin = soil1(j)%mp(bz_lyr)%lab + nh3_begin = soil1(j)%mn(bz_lyr)%nh4 + no3_begin = soil1(j)%mn(bz_lyr)%no3 + solp_begin = soil1(j)%mp(bz_lyr)%lab - !! Add STE f.coli concentration by volumetric averaging + !! Add STE f.coli concentration by volumetric averaging xx = 10.* soil(j)%phys(bz_lyr)%st * bza / (qin & + 10.* soil(j)%phys(bz_lyr)%st * bza) - fcoli(j) = fcoli(j) * xx + sepdb(sep(isep)%typ)%fcolis * (1.- xx) ! J.Jeong 3/09/09 - - !! nutrients reaction rate (Equation 4-13) - rtrate = biom(j) * bza / (bz_vol * soil(j)%phys(bz_lyr)%por) - - !! BOD (kg/ha) 4-14 ! - bod_rt = max(0.,sep(isep)%bod_dc * rtrate) !bod + fcoli(j) = fcoli(j) * xx + sepdb(sep(isep)%typ)%fcolis * (1.- xx) ! J.Jeong 3/09/09 + + !! nutrients reaction rate (Equation 4-13) + rtrate = biom(j) * bza / (bz_vol * soil(j)%phys(bz_lyr)%por) + + !! BOD (kg/ha) 4-14 ! + bod_rt = max(0.,sep(isep)%bod_dc * rtrate) !bod if (bod_rt>4) bod_rt=4 - rbod = bodi * (1.- Exp(-bod_rt)) - bode = bodi - rbod !mg/l - bio_bod(j) = bode * (soil(j)%phys(bz_lyr)%st * 10)/1000. !kg/ha + rbod = bodi * (1.- Exp(-bod_rt)) + bode = bodi - rbod !mg/l + bio_bod(j) = bode * (soil(j)%phys(bz_lyr)%st * 10)/1000. !kg/ha - !! Fecal coliform(cfu/100ml) Eq 4-14, J.Jeong 3/09/09 - fcoli_rt = max(0.,sep(isep)%fecal * rtrate) !fecal coliform - rfcoli = fcoli(j) * (1.- exp(-fcoli_rt)) - fcoli(j) = fcoli(j) - rfcoli + !! Fecal coliform(cfu/100ml) Eq 4-14, J.Jeong 3/09/09 + fcoli_rt = max(0.,sep(isep)%fecal * rtrate) !fecal coliform + rfcoli = fcoli(j) * (1.- exp(-fcoli_rt)) + fcoli(j) = fcoli(j) - rfcoli - !! change in nh3 & no3 in soil pools due to nitrification(kg/ha) Eq.4-13, 4-14 - ntr_rt = max(0.,sep(isep)%nitr * rtrate) !nitrification - rnit = soil1(j)%mn(bz_lyr)%nh4 * (1. - Exp(-ntr_rt)) !! J.Jeong 4/03/09 - soil1(j)%mn(bz_lyr)%nh4 = soil1(j)%mn(bz_lyr)%nh4 - rnit !J.Jeong 3/09/09 - soil1(j)%mn(bz_lyr)%no3 = soil1(j)%mn(bz_lyr)%no3 + rnit !J.Jeong 3/09/09 - - !ammonium percolation - nperc = 0.2 * qout / qi * soil1(j)%mn(bz_lyr)%nh4 - nperc = min(nperc,0.5 * soil1(j)%mn(bz_lyr)%nh4) - soil1(j)%mn(bz_lyr)%nh4 = soil1(j)%mn(bz_lyr)%nh4 - nperc - soil1(j)%mn(bz_lyr+1)%nh4 = soil1(j)%mn(bz_lyr+1)%nh4 + nperc + !! change in nh3 & no3 in soil pools due to nitrification(kg/ha) Eq.4-13, 4-14 + ntr_rt = max(0.,sep(isep)%nitr * rtrate) !nitrification + rnit = soil1(j)%mn(bz_lyr)%nh4 * (1. - Exp(-ntr_rt)) !! J.Jeong 4/03/09 + soil1(j)%mn(bz_lyr)%nh4 = soil1(j)%mn(bz_lyr)%nh4 - rnit !J.Jeong 3/09/09 + soil1(j)%mn(bz_lyr)%no3 = soil1(j)%mn(bz_lyr)%no3 + rnit !J.Jeong 3/09/09 + + !ammonium percolation + nperc = 0.2 * qout / qi * soil1(j)%mn(bz_lyr)%nh4 + nperc = min(nperc,0.5 * soil1(j)%mn(bz_lyr)%nh4) + soil1(j)%mn(bz_lyr)%nh4 = soil1(j)%mn(bz_lyr)%nh4 - nperc + soil1(j)%mn(bz_lyr+1)%nh4 = soil1(j)%mn(bz_lyr+1)%nh4 + nperc - !! denitrification,(kg/ha) Eq 4-14 - dentr_rt = max(0.,sep(isep)%denitr * rtrate) !denitrification - rdenit = soil1(j)%mn(bz_lyr)%no3 * (1. - Exp(-dentr_rt)) !J.Jeong 3/09/09 - soil1(j)%mn(bz_lyr)%no3 = soil1(j)%mn(bz_lyr)%no3 - rdenit !J.Jeong 3/09/09 + !! denitrification,(kg/ha) Eq 4-14 + dentr_rt = max(0.,sep(isep)%denitr * rtrate) !denitrification + rdenit = soil1(j)%mn(bz_lyr)%no3 * (1. - Exp(-dentr_rt)) !J.Jeong 3/09/09 + soil1(j)%mn(bz_lyr)%no3 = soil1(j)%mn(bz_lyr)%no3 - rdenit !J.Jeong 3/09/09 - !soil volume for sorption: soil thickness below biozone + !soil volume for sorption: soil thickness below biozone svolp = (soil(j)%phys(nly)%d - sep(isep)%z) * bza * 10. !m3, !max adsorption amnt: linear isotherm, McCray 2005 solpconc = soil1(j)%mp(bz_lyr)%lab * bza / qi * 1000. !mg/l - solpsorb = min(sep(isep)%pdistrb * solpconc,sep(isep)%psorpmax) !mgP/kgSoil - solpsorb = 1.6 * 1.e-3 * solpsorb * svolp * & - (1-soil(j)%phys(bz_lyr)%por) !kgP sorption potential + solpsorb = min(sep(isep)%pdistrb * solpconc,sep(isep)%psorpmax) !mgP/kgSoil + solpsorb = 1.6 * 1.e-3 * solpsorb * svolp * & + (1-soil(j)%phys(bz_lyr)%por) !kgP sorption potential !check if max. P sorption is reached if(soil1(j)%mp(bz_lyr)%lab * bza .0001) then + if (surfq(j) > .0001) then !! vfs comnposed of two sections one with more concentrated flow than the other !! Calculate drainage area of vfs 1 2 3 in ha - drain_vfs1 = (1. - hru(j)%lumv%vfscon)* hru(j)%area_ha - drain_vfs2 = ((1. - hru(j)%lumv%vfsch) * hru(j)%lumv%vfscon)* hru(j)%area_ha - drain_vfs3 = hru(j)%lumv%vfscon * hru(j)%lumv%vfsch * hru(j)%area_ha + drain_vfs1 = (1. - hru(j)%lumv%vfscon)* hru(j)%area_ha + drain_vfs2 = ((1. - hru(j)%lumv%vfsch) * hru(j)%lumv%vfscon)* hru(j)%area_ha + drain_vfs3 = hru(j)%lumv%vfscon * hru(j)%lumv%vfsch * hru(j)%area_ha !! Calculate area of vfs 1 and 2 in ha - area_vfs1 = hru(j)%area_ha * 0.9 / hru(j)%lumv%vfsratio - area_vfs2 = hru(j)%area_ha * 0.1 / hru(j)%lumv%vfsratio + area_vfs1 = hru(j)%area_ha * 0.9 / hru(j)%lumv%vfsratio + area_vfs2 = hru(j)%area_ha * 0.1 / hru(j)%lumv%vfsratio - !! Calculate drainage area to vfs area ratio (unitless) - vfs_ratio1 = drain_vfs1/area_vfs1 - vfs_ratio2 = drain_vfs2/area_vfs2 + !! Calculate drainage area to vfs area ratio (unitless) + vfs_ratio1 = drain_vfs1/area_vfs1 + vfs_ratio2 = drain_vfs2/area_vfs2 !! calculate runoff depth over buffer area in mm - vfs_depth1 = vfs_ratio1 * surfq(j) - vfs_depth2 = vfs_ratio2 * surfq(j) + vfs_depth1 = vfs_ratio1 * surfq(j) + vfs_depth2 = vfs_ratio2 * surfq(j) !! calculate sediment loading over buffer area in kg/m^2 - vfs_sed1 = (sedyld(j) / hru(j)%area_ha * 1000. * drain_vfs1) / (area_vfs1 * 10000.) - vfs_sed2 = (sedyld(j) / hru(j)%area_ha * 1000. * drain_vfs2) / (area_vfs2 * 10000.) + vfs_sed1 = (sedyld(j) / hru(j)%area_ha * 1000. * drain_vfs1) / (area_vfs1 * 10000.) + vfs_sed2 = (sedyld(j) / hru(j)%area_ha * 1000. * drain_vfs2) / (area_vfs2 * 10000.) !! calculate Runoff Removal by vfs (used for nutrient removal estimation only) based on runoff depth and ksat !! Based on vfsmod simulations surq_remove1 = 75.8-10.8 * Log(vfs_depth1) + 25.9 * Log(soil(j)%phys(1)%k) - if (surq_remove1 > 100.) surq_remove1 = 100. - if (surq_remove1 < 0.) surq_remove1 = 0. + if (surq_remove1 > 100.) surq_remove1 = 100. + if (surq_remove1 < 0.) surq_remove1 = 0. surq_remove2 = 75.8-10.8 * Log(vfs_depth2) + 25.9 * Log(soil(j)%phys(1)%k) - if (surq_remove2 > 100.) surq_remove2 = 100. - if (surq_remove2 < 0.) surq_remove2 = 0. + if (surq_remove2 > 100.) surq_remove2 = 100. + if (surq_remove2 < 0.) surq_remove2 = 0. - surq_remove = (surq_remove1 * drain_vfs1 + surq_remove2 * drain_vfs2)/hru(j)%area_ha + surq_remove = (surq_remove1 * drain_vfs1 + surq_remove2 * drain_vfs2)/hru(j)%area_ha !! calculate sediment Removal - Based on measured data from literature - sed_remove1 = 79.0 - 1.04 * vfs_sed1 + 0.213 * surq_remove1 - if (sed_remove1 > 100.) sed_remove1 = 100. - if (sed_remove1 < 0.) sed_remove1 = 0. + sed_remove1 = 79.0 - 1.04 * vfs_sed1 + 0.213 * surq_remove1 + if (sed_remove1 > 100.) sed_remove1 = 100. + if (sed_remove1 < 0.) sed_remove1 = 0. - sed_remove2 = 79.0 - 1.04 * vfs_sed2 + 0.213 * surq_remove1 - if (sed_remove2 > 100.) sed_remove2 = 100. - if (sed_remove2 < 0.) sed_remove2 = 0. + sed_remove2 = 79.0 - 1.04 * vfs_sed2 + 0.213 * surq_remove1 + if (sed_remove2 > 100.) sed_remove2 = 100. + if (sed_remove2 < 0.) sed_remove2 = 0. - sed_remove = (sed_remove1 * drain_vfs1 + sed_remove2 * drain_vfs2) / hru(j)%area_ha - - sedyld(j) = sedyld(j) * (1. - sed_remove / 100.) + sed_remove = (sed_remove1 * drain_vfs1 + sed_remove2 * drain_vfs2) / hru(j)%area_ha + + sedyld(j) = sedyld(j) * (1. - sed_remove / 100.) sedyld(j) = Max(0., sedyld(j)) - sedtrap = sedyld(j) * sed_remove / 100. - xrem = 0. + sedtrap = sedyld(j) * sed_remove / 100. + xrem = 0. if (sedtrap <= lagyld(j)) then lagyld(j) = lagyld(j) - sedtrap @@ -174,59 +174,59 @@ subroutine smp_filter !! Calculate Organic Nitrogen Removal !! Based on measured data from literature - remove1 = 0.036 * sed_remove1 ** 1.69 - if (remove1 > 100.) remove1 = 100. - if (remove1 < 0.) remove1 = 0. + remove1 = 0.036 * sed_remove1 ** 1.69 + if (remove1 > 100.) remove1 = 100. + if (remove1 < 0.) remove1 = 0. - remove2 = 0.036 * sed_remove2 ** 1.69 - if (remove2 > 100.) remove2 = 100. - if (remove2 < 0.) remove2 = 0. - - orgn_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha - sedorgn(j) = sedorgn(j) * (1. - orgn_remove / 100.) + remove2 = 0.036 * sed_remove2 ** 1.69 + if (remove2 > 100.) remove2 = 100. + if (remove2 < 0.) remove2 = 0. + + orgn_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha + sedorgn(j) = sedorgn(j) * (1. - orgn_remove / 100.) !! calculate Nitrate removal from surface runoff !! Based on measured data from literature - - remove1 = 39.4 + 0.584 * surq_remove1 - if (remove1 > 100.) remove1 = 100. - if (remove1 < 0.) remove1 = 0. + + remove1 = 39.4 + 0.584 * surq_remove1 + if (remove1 > 100.) remove1 = 100. + if (remove1 < 0.) remove1 = 0. - remove2 = 39.4 + 0.584 * surq_remove2 - if (remove2 > 100.) remove2 = 100. + remove2 = 39.4 + 0.584 * surq_remove2 + if (remove2 > 100.) remove2 = 100. if (remove2 < 0.) remove2 = 0. surqno3_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha - surqno3(j) = surqno3(j) * (1. - surqno3_remove / 100.) + surqno3(j) = surqno3(j) * (1. - surqno3_remove / 100.) !! calculate Particulate P removal from surface runoff !!Based on measured data from literature - remove1 = 0.903 * sed_remove1 - if (remove1 > 100.) remove1 = 100. - if (remove1 < 0.) remove1 = 0. - - remove2 = 0.903 * sed_remove2 - if (remove2 > 100.) remove2 = 100. - if (remove2 < 0.) remove2 = 0. + remove1 = 0.903 * sed_remove1 + if (remove1 > 100.) remove1 = 100. + if (remove1 < 0.) remove1 = 0. + + remove2 = 0.903 * sed_remove2 + if (remove2 > 100.) remove2 = 100. + if (remove2 < 0.) remove2 = 0. - partP_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha - sedminpa(j) = sedminpa(j) * (1. - partP_remove / 100.) - sedminps(j) = sedminps(j) * (1. - partP_remove / 100.) - sedorgp(j) = sedorgp(j) * (1. - partP_remove / 100.) + partP_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha + sedminpa(j) = sedminpa(j) * (1. - partP_remove / 100.) + sedminps(j) = sedminps(j) * (1. - partP_remove / 100.) + sedorgp(j) = sedorgp(j) * (1. - partP_remove / 100.) !! Calculate Soluble P removal from surface runoff !! DP% = - 6.14 + 1.13 Runoff% - remove1 = 29.3 + 0.51 * surq_remove1 - if (remove1 > 100.) remove1 = 100. - if (remove1 < 0.) remove1 = 0. - - remove21 = 29.3 + 0.51 * surq_remove2 - if (remove2 > 100.) remove2 = 100. - if (remove2 < 0.) remove2 = 0. + remove1 = 29.3 + 0.51 * surq_remove1 + if (remove1 > 100.) remove1 = 100. + if (remove1 < 0.) remove1 = 0. + + remove21 = 29.3 + 0.51 * surq_remove2 + if (remove2 > 100.) remove2 = 100. + if (remove2 < 0.) remove2 = 0. - solp_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha - surqsolp(j) = surqsolp(j) * (1. - solp_remove / 100.) + solp_remove = (remove1 * drain_vfs1 + remove2 * drain_vfs2)/hru(j)%area_ha + surqsolp(j) = surqsolp(j) * (1. - solp_remove / 100.) !! Calculate pesticide removal !! based on the sediment and runoff removal only @@ -235,7 +235,7 @@ subroutine smp_filter hpestb_d(j)%pest(k)%sed = hpestb_d(j)%pest(k)%sed * (1. - sed_remove / 100.) end do - end if ! if (surfq(j) > .0001) + end if ! if (surfq(j) > .0001) return end subroutine smp_filter \ No newline at end of file diff --git a/src/smp_grass_wway.f90 b/src/smp_grass_wway.f90 index 44c011d..930ef0b 100644 --- a/src/smp_grass_wway.f90 +++ b/src/smp_grass_wway.f90 @@ -6,12 +6,12 @@ subroutine smp_grass_wway !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ihru |none |HRU number -!! surfq(:) |mm H2O |amount of water in surface runoff generated -!! grwat_l(:) |km |Length of Grass Waterway -!! grwat_w(:) |none |Width of grass waterway -!! grwat_s(:) |m/m |Slope of grass waterway -!! grwat_spcon(:) |none |sediment transport coefficant defined by user -!! tc_gwat(:) |none |Time of concentration for Grassed waterway and its drainage area +!! surfq(:) |mm H2O |amount of water in surface runoff generated +!! grwat_l(:) |km |Length of Grass Waterway +!! grwat_w(:) |none |Width of grass waterway +!! grwat_s(:) |m/m |Slope of grass waterway +!! grwat_spcon(:) |none |sediment transport coefficant defined by user +!! tc_gwat(:) |none |Time of concentration for Grassed waterway and its drainage area !! surfq(:) |mm H2O |surface runoff generated on day in HRU !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ @@ -22,7 +22,7 @@ subroutine smp_grass_wway !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! qp_cms |m^3/s |peak runoff rate for the day -!! rcharea |m^2 |cross-sectional area of flow +!! rcharea |m^2 |cross-sectional area of flow !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ @@ -42,15 +42,15 @@ subroutine smp_grass_wway real :: sed_remove = 0. !% |percent of sediment capture in VFS real :: sf_sed = 0. !kg/m^2 |sediment loads on sides of waterway real :: vc = 0. !m/s |flow velocity in reach - real :: chflow_day = 0. !m^3/day |Runoff + real :: chflow_day = 0. !m^3/day |Runoff integer :: j = 0 !none |HRU number real :: rchdep = 0. !m |depth of flow on day real :: p = 0. ! | real :: rh = 0. !m |hydraulic radius real :: qman !m^3/s or m/s |flow rate or flow velocity - real :: sedin = 0. !mg |Sediment in waterway + real :: sedin = 0. !mg |Sediment in waterway real :: sf_depth = 0. ! | - real :: sedint = 0. !mg |Sediment into waterway channel + real :: sedint = 0. !mg |Sediment into waterway channel real :: cyin = 0. ! | real :: cych = 0. ! | real :: rcharea = 0. @@ -58,23 +58,23 @@ subroutine smp_grass_wway real :: deg = 0. !metric tons |sediment reentrained in water by channel ! |degradation real :: dep = 0. ! | - real :: sedout = 0. !mg | Sediment out of waterway channel + real :: sedout = 0. !mg | Sediment out of waterway channel real :: sed_frac = 0. ! | real :: surq_frac = 0. ! | real :: sedtrap = 0. ! | real :: xrem = 0. ! | integer :: k = 0 !m^3/s |Total number of HRUs plus this HRU number -!! set variables +!! set variables j = ihru -!! do this only if there is surface runoff this day +!! do this only if there is surface runoff this day if (surfq(j) > 0.001) then !! compute channel peak rate using SCS triangular unit hydrograph -!! Calculate average flow based on 3 hours of runoff - chflow_day = 1000. * surfq(j) * hru(ihru)%km +!! Calculate average flow based on 3 hours of runoff + chflow_day = 1000. * surfq(j) * hru(ihru)%km chflow_m3 = chflow_day/10800 qp_cms = 2. * chflow_m3 / (1.5 * tc_gwat(j)) @@ -100,40 +100,40 @@ subroutine smp_grass_wway !! Sediment yield (kg) from fraction of area drained by waterway - sedin = sedyld(ihru) * hru(ihru)%km + sedin = sedyld(ihru) * hru(ihru)%km !! Calculate sediment losses in sheetflow at waterway sides !! calculate area of sheeflow in m^2 assumne *:1 side slope 8.06 = (8^2+1^2)^.5 - sf_area = (hru(j)%lumv%grwat_d - rchdep) * 8.06 * hru(j)%lumv%grwat_l * 1000 + sf_area = (hru(j)%lumv%grwat_d - rchdep) * 8.06 * hru(j)%lumv%grwat_l * 1000 !! Adjust Area to account for flow nonuniformities White and Arnold 2009 found half of flow in VFS !!handled by 10% of VFS area. Waterways likely even more concentrated Assume only 20% of sideslope acts as filters if (sf_area > 1.e-6) then - sf_area = sf_area * 0.20 + sf_area = sf_area * 0.20 !! calculate runoff depth over sheetflow area in mm - sf_depth=surfq(j) * hru(ihru)%km * 1000000/sf_area + sf_depth=surfq(j) * hru(ihru)%km * 1000000/sf_area !! Calculate sediment load on sheetflow area kg/ha - sf_sed = sedin * 1000 / sf_area + sf_sed = sedin * 1000 / sf_area !! Calculate runoff and sediment losses taken from mostly from filter.f end if - if (sf_area > 0.) then -!! surq_remove = 75.8 - 10.8 * Log(sf_depth) + 25.9 + if (sf_area > 0.) then +!! surq_remove = 75.8 - 10.8 * Log(sf_depth) + 25.9 !! & * Log(sol_k(1,j)) - !! Simpler form derived from vfsmod simulations. r2 = 0.57 Publication pending white and arnold 2008 + !! Simpler form derived from vfsmod simulations. r2 = 0.57 Publication pending white and arnold 2008 - surq_remove = 95.6 - 10.79 * Log(sf_depth) - if (surq_remove > 100.) surq_remove = 100. - if (surq_remove < 0.) surq_remove = 0. + surq_remove = 95.6 - 10.79 * Log(sf_depth) + if (surq_remove > 100.) surq_remove = 100. + if (surq_remove < 0.) surq_remove = 0. - sed_remove = 79.0 - 1.04 * sf_sed + 0.213 * surq_remove - if (sed_remove > 100.) sed_remove = 100. - if (sed_remove < 0.) sed_remove = 0. + sed_remove = 79.0 - 1.04 * sf_sed + 0.213 * surq_remove + if (sed_remove > 100.) sed_remove = 100. + if (sed_remove < 0.) sed_remove = 0. - Else - sed_remove = 0 - surq_remove = 0 - endif - sedint = sedin * (1. - sed_remove / 100.) + Else + sed_remove = 0 + surq_remove = 0 + endif + sedint = sedin * (1. - sed_remove / 100.) !! calculate flow velocity vc = 0.001 @@ -157,59 +157,59 @@ subroutine smp_grass_wway !! Calculate deposition in mg depnet = chflow_day * (cyin - cych) if (depnet < 0.) depnet = 0 - if (depnet > sedint) depnet = sedint + if (depnet > sedint) depnet = sedint endif !! Calculate sediment out of waterway channel - sedout = sedint - depnet + sedout = sedint - depnet !! Calculate total fraction of sediment and surface runoff transported if (sedyld(j) < .0001) sedyld(j) = .0001 - sed_frac = sedout/sedyld(j) + sed_frac = sedout/sedyld(j) - surq_frac = 1 - surq_remove/100 + surq_frac = 1 - surq_remove/100 !! Subtract reductions from sediment, nutrients, bacteria, and pesticides NOT SURFACE RUNOFF to protect water balance sedtrap = sedyld(j) * (1. - sed_frac) - sedyld(j) = sedyld(j) * sed_frac - sedminpa(j) = sedminpa(j) * sed_frac - sedminps(j) = sedminps(j) * sed_frac - sedorgp(j) = sedorgp(j) * sed_frac - surqsolp(j) = surqsolp(j) * surq_frac - sedorgn(j) = sedorgn(j) * sed_frac - surqno3(j) = surqno3(j) * surq_frac + sedyld(j) = sedyld(j) * sed_frac + sedminpa(j) = sedminpa(j) * sed_frac + sedminps(j) = sedminps(j) * sed_frac + sedorgp(j) = sedorgp(j) * sed_frac + surqsolp(j) = surqsolp(j) * surq_frac + sedorgn(j) = sedorgn(j) * sed_frac + surqno3(j) = surqno3(j) * surq_frac xrem = 0. - if (sedtrap <= lagyld(j)) then - lagyld(j) = lagyld(j) - sedtrap - else - xrem = sedtrap - lagyld(j) - lagyld(j) = 0. - if (xrem <= sanyld(j)) then - sanyld(j) = sanyld(j) - xrem - else - xrem = xrem - sanyld(j) - sanyld(j) = 0. - if (xrem <= sagyld(j)) then - sagyld(j) = sagyld(j) - xrem - else - xrem = xrem - sagyld(j) - sagyld(j) = 0. - if (xrem <= silyld(j)) then - silyld(j) = silyld(j) - xrem - else - xrem = xrem - silyld(j) - silyld(j) = 0. - if (xrem <= clayld(j)) then - clayld(j) = clayld(j) - xrem - else - xrem = xrem - clayld(j) - clayld(j) = 0. - end if - end if - end if - end if - end if + if (sedtrap <= lagyld(j)) then + lagyld(j) = lagyld(j) - sedtrap + else + xrem = sedtrap - lagyld(j) + lagyld(j) = 0. + if (xrem <= sanyld(j)) then + sanyld(j) = sanyld(j) - xrem + else + xrem = xrem - sanyld(j) + sanyld(j) = 0. + if (xrem <= sagyld(j)) then + sagyld(j) = sagyld(j) - xrem + else + xrem = xrem - sagyld(j) + sagyld(j) = 0. + if (xrem <= silyld(j)) then + silyld(j) = silyld(j) - xrem + else + xrem = xrem - silyld(j) + silyld(j) = 0. + if (xrem <= clayld(j)) then + clayld(j) = clayld(j) - xrem + else + xrem = xrem - clayld(j) + clayld(j) = 0. + end if + end if + end if + end if + end if sanyld(j) = Max(0., sanyld(j)) silyld(j) = Max(0., silyld(j)) clayld(j) = Max(0., clayld(j)) diff --git a/src/soil_data_module.f90 b/src/soil_data_module.f90 index c57f907..5d6f077 100644 --- a/src/soil_data_module.f90 +++ b/src/soil_data_module.f90 @@ -12,7 +12,7 @@ module soil_data_module type soiltest_db character(len=16) :: name = "default" - real :: exp_co = .001 ! |depth coefficient to adjust concentrations for depth + real :: exp_co = .001 ! |depth coefficient to adjust concentrations for depth real :: lab_p = 5. !ppm |labile P in soil surface real :: nitrate = 7. !ppm |nitrate N in soil surface real :: fr_hum_act = .02 !0-1 |fraction of soil humus that is active @@ -29,7 +29,7 @@ module soil_data_module !!!!!! OLD type type soiltest_db_old character(len=16) :: name = "default" - real :: exp_co = .001 ! |depth coefficient to adjust concentrations for depth + real :: exp_co = .001 ! |depth coefficient to adjust concentrations for depth real :: totaln = 13. !ppm |total N in soil real :: inorgn = 6. !ppm |inorganic N in soil surface real :: orgn = 3. !ppm |organic N in soil surface diff --git a/src/soil_module.f90 b/src/soil_module.f90 index 45895f5..845e995 100644 --- a/src/soil_module.f90 +++ b/src/soil_module.f90 @@ -50,7 +50,7 @@ module soil_module type (soil_physical_properties),dimension (:), allocatable:: phys1 type soil_profile - character(len=16) :: snam = "" !! NA soil series name + character(len=20) :: snam = "" !! NA soil series name character(len=16) :: hydgrp = "" !! NA hydrologic soil group character(len=16) :: texture = "" integer :: nly = 0 !! none number of soil layers diff --git a/src/soil_nutcarb_init.f90 b/src/soil_nutcarb_init.f90 index 1cf8db1..b08ee50 100644 --- a/src/soil_nutcarb_init.f90 +++ b/src/soil_nutcarb_init.f90 @@ -34,11 +34,19 @@ subroutine soil_nutcarb_init (isol) isolt = sol_plt_ini(isol_pl)%nut ! isolt = 0 = default in type !! set soil carbon - soil1(ihru)%cbn(1) = max(.001, soildb(isol)%ly(1)%cbn) !! assume 0.001% carbon if zero + soil1(ihru)%cbn(1) = max(0.001, soildb(isol)%ly(1)%cbn) !! assume 0.001% carbon if zero !! calculate percent carbon for lower layers using exponential decrease + !do ly = 2, nly + !dep_frac = Exp(-solt_db(isolt)%exp_co * soil(ihru)%phys(ly)%d) + !soil1(ihru)%cbn(ly) = soil1(ihru)%cbn(1) * dep_frac + !end do + !! use carbon content in the soils database do ly = 2, nly - dep_frac = Exp(-solt_db(isolt)%exp_co * soil(ihru)%phys(ly)%d) - soil1(ihru)%cbn(ly) = soil1(ihru)%cbn(1) * dep_frac + if (ly - 1 <= soildb(isol)%s%nly) then + soil1(ihru)%cbn(ly) = soildb(isol)%ly(ly-1)%cbn + else + soil1(ihru)%cbn(ly) = soildb(isol)%ly(soildb(isol)%s%nly)%cbn + end if end do !! calculate initial nutrient contents of layers, profile and @@ -67,15 +75,15 @@ subroutine soil_nutcarb_init (isol) soil1(ihru)%mp(ly)%lab = soil1(ihru)%mp(ly)%lab * wt1 !! mg/kg => kg/ha !! set active mineral P pool based on dynamic PSP MJW - if (bsn_cc%sol_P_model == 1) then - !! Allow Dynamic PSP Ratio + if (bsn_cc%sol_P_model == 1) then + !! Allow Dynamic PSP Ratio !! convert to concentration solp = soil1(ihru)%mp(ly)%lab / wt1 - !! PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43 - if (soil(ihru)%phys(ly)%clay > 0.) then + !! PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43 + if (soil(ihru)%phys(ly)%clay > 0.) then psp = -0.045 * log(soil(ihru)%phys(ly)%clay) + (0.001 * solp) psp = psp - (0.035 * soil1(ihru)%cbn(ly)) + 0.43 - endif + endif !! Limit PSP range if (psp < .10) then psp = 0.10 @@ -88,24 +96,24 @@ subroutine soil_nutcarb_init (isol) soil1(ihru)%mp(ly)%act = soil1(ihru)%mp(ly)%lab * (1. - psp) / psp !! Set Stable pool based on dynamic coefficient - if (bsn_cc%sol_P_model == 1) then !! From White et al 2009 + if (bsn_cc%sol_P_model == 1) then !! From White et al 2009 !! convert to concentration for ssp calculation - actp = soil1(ihru)%mp(ly)%act / wt1 - solp = soil1(ihru)%mp(ly)%lab / wt1 + actp = soil1(ihru)%mp(ly)%act / wt1 + solp = soil1(ihru)%mp(ly)%lab / wt1 !! estimate Total Mineral P in this soil based on data from sharpley 2004 - ssp = 25.044 * (actp + solp)** (-0.3833) - !!limit SSP Range - if (ssp > 7.) ssp = 7. - if (ssp < 1.) ssp = 1. - soil1(ihru)%mp(ly)%sta = ssp * (soil1(ihru)%mp(ly)%act + soil1(ihru)%mp(ly)%lab) + ssp = 25.044 * (actp + solp)** (-0.3833) + !!limit SSP Range + if (ssp > 7.) ssp = 7. + if (ssp < 1.) ssp = 1. + soil1(ihru)%mp(ly)%sta = ssp * (soil1(ihru)%mp(ly)%act + soil1(ihru)%mp(ly)%lab) else - !! the original code - soil1(ihru)%mp(ly)%sta = 4. * soil1(ihru)%mp(ly)%act - end if + !! the original code + soil1(ihru)%mp(ly)%sta = 4. * soil1(ihru)%mp(ly)%act + end if end do !! set initial organic pools - originally by Zhang - do ly = 1, nly + do ly = 1, nly !initialize total soil organic pool - no litter !kg/ha = mm * t/m3 * m/1,000 mm * 1,000 kg/t * 10,000 m2/ha @@ -184,7 +192,7 @@ subroutine soil_nutcarb_init (isol) !soil1(ihru)%water(ly)%n = !soil1(ihru)%water(ly)%p = - end do + end do return end subroutine soil_nutcarb_init \ No newline at end of file diff --git a/src/soil_nutcarb_write.f90 b/src/soil_nutcarb_write.f90 index ce214c5..3c746de 100644 --- a/src/soil_nutcarb_write.f90 +++ b/src/soil_nutcarb_write.f90 @@ -50,6 +50,15 @@ subroutine soil_nutcarb_write soil1(j)%tot_org = soil_org_z soil_prof_hact = soil_org_z soil_prof_hsta = soil_org_z + soil_prof_hsta = soil_org_z + soil_prof_str = soil_org_z + soil_prof_lig = soil_org_z + soil_prof_meta = soil_org_z + soil_prof_man = soil_org_z + soil_prof_hs = soil_org_z + soil_prof_hp = soil_org_z + soil_prof_microb = soil_org_z + soil_prof_water = soil_org_z do ly = 1, soil(j)%nly soil_prof_hact = soil_prof_hact + soil1(j)%hact(ly) soil_prof_hsta = soil_prof_hsta + soil1(j)%hsta(ly) @@ -62,7 +71,9 @@ subroutine soil_nutcarb_write soil_prof_microb = soil_prof_microb + soil1(j)%microb(ly) soil_prof_water = soil_prof_water + soil1(j)%water(ly) end do - soil1(j)%tot_org = soil_prof_hact + soil_prof_hsta + soil_prof_microb + ! soil1(j)%tot_org = soil_prof_hact + soil_prof_hsta + soil_prof_microb + soil1(j)%tot_org = soil_prof_hs + soil_prof_hp + soil_prof_microb + soil_prof_meta + & + soil_prof_str + soil_prof_lig !write all organic carbon for the plant community write (4560,*) time%day, time%mo, time%day_mo, time%yrc, j, ob(iob)%gis_id, ob(iob)%name, & diff --git a/src/soil_phys_init.f90 b/src/soil_phys_init.f90 index 8c9ab4b..d8f89cb 100644 --- a/src/soil_phys_init.f90 +++ b/src/soil_phys_init.f90 @@ -62,13 +62,13 @@ subroutine soil_phys_init (isol) if (sol(isol)%phys(j)%k <= 0.0) then if (sol(isol)%s%hydgrp == "A") then sol(isol)%phys(j)%k = a - else + else if (sol(isol)%s%hydgrp == "B") then sol(isol)%phys(j)%k = b - else + else if (sol(isol)%s%hydgrp == "C") then sol(isol)%phys(j)%k = c - else + else if (sol(isol)%s%hydgrp == "D") then sol(isol)%phys(j)%k = d !Claire 12/2/09 else @@ -131,15 +131,15 @@ subroutine soil_phys_init (isol) sol(isol)%s%det_lag = 1. - sol(isol)%s%det_san - & sol(isol)%s%det_sil - sol(isol)%s%det_cla - sol(isol)%s%det_sag !! Large Aggregate fraction -!! Error check. May happen for soils with more sand +!! Error check. May happen for soils with more sand !! Soil not typical of mid-western USA !! The fraction wont add upto 1.0 - if (sol(isol)%s%det_lag < 0.) then - sol(isol)%s%det_san = sol(isol)%s%det_san/(1 - sol(isol)%s%det_lag) - sol(isol)%s%det_sil = sol(isol)%s%det_sil/(1 - sol(isol)%s%det_lag) - sol(isol)%s%det_cla = sol(isol)%s%det_cla/(1 - sol(isol)%s%det_lag) - sol(isol)%s%det_sag = sol(isol)%s%det_sag/(1 - sol(isol)%s%det_lag) - sol(isol)%s%det_lag = 0. + if (sol(isol)%s%det_lag < 0.) then + sol(isol)%s%det_san = sol(isol)%s%det_san/(1 - sol(isol)%s%det_lag) + sol(isol)%s%det_sil = sol(isol)%s%det_sil/(1 - sol(isol)%s%det_lag) + sol(isol)%s%det_cla = sol(isol)%s%det_cla/(1 - sol(isol)%s%det_lag) + sol(isol)%s%det_sag = sol(isol)%s%det_sag/(1 - sol(isol)%s%det_lag) + sol(isol)%s%det_lag = 0. end if !! initialize water/drainage coefs for each soil layer diff --git a/src/soil_text_init.f90 b/src/soil_text_init.f90 index 87f0672..8c474d5 100644 --- a/src/soil_text_init.f90 +++ b/src/soil_text_init.f90 @@ -55,12 +55,12 @@ subroutine soil_text_init (isol) !! Error check. May happen for soils with more sand !! Soil not typical of mid-western USA The fraction wont add upto 1.0 - if (soil(isol)%det_lag < 0.) then - soil(isol)%det_san = soil(isol)%det_san/(1 - soil(isol)%det_lag) - soil(isol)%det_sil = soil(isol)%det_sil/(1 - soil(isol)%det_lag) - soil(isol)%det_cla = soil(isol)%det_cla/(1 - soil(isol)%det_lag) - soil(isol)%det_sag = soil(isol)%det_sag/(1 - soil(isol)%det_lag) - soil(isol)%det_lag = 0. + if (soil(isol)%det_lag < 0.) then + soil(isol)%det_san = soil(isol)%det_san/(1 - soil(isol)%det_lag) + soil(isol)%det_sil = soil(isol)%det_sil/(1 - soil(isol)%det_lag) + soil(isol)%det_cla = soil(isol)%det_cla/(1 - soil(isol)%det_lag) + soil(isol)%det_sag = soil(isol)%det_sag/(1 - soil(isol)%det_lag) + soil(isol)%det_lag = 0. end if return diff --git a/src/soils_init.f90 b/src/soils_init.f90 index b2ca507..30894f5 100644 --- a/src/soils_init.f90 +++ b/src/soils_init.f90 @@ -134,7 +134,7 @@ subroutine soils_init if (sep(isep)%opt /= 0) then dep_new1 = 0. dep_new2 = 0. - if (sep(isep)%z + sep(isep)%thk > soil(ihru)%phys(nly)%d) then + if (sep(isep)%z + sep(isep)%thk > soil(ihru)%phys(nly)%d) then i_sep(ihru) = nly + 1 dep_new1 = sep(isep)%z - sep(isep)%thk dep_new2 = 0. @@ -200,6 +200,7 @@ subroutine soils_init allocate (soil1_init(ihru)%man(nly)) allocate (soil1_init(ihru)%water(nly)) + call soil_nutcarb_init(isol) !! initialize soil nutrient/carbon parameters Jaehak 2024 end do return diff --git a/src/sq_canopyint.f90 b/src/sq_canopyint.f90 index 1368e81..cf8d3ec 100644 --- a/src/sq_canopyint.f90 +++ b/src/sq_canopyint.f90 @@ -87,7 +87,7 @@ subroutine sq_canopyint precip_eff = precip_eff - (canmxl - canstor(j)) canstor(j) = canmxl endif - end if + end if ! time%step > 1 return end subroutine sq_canopyint \ No newline at end of file diff --git a/src/sq_greenampt.f90 b/src/sq_greenampt.f90 index 3883bf3..c93e7e8 100644 --- a/src/sq_greenampt.f90 +++ b/src/sq_greenampt.f90 @@ -179,14 +179,14 @@ subroutine sq_greenampt end if return - 5000 format(//,"Excess rainfall calculation for day ",i3," of year ", & - i4," for sub-basin",i4,".",/) - 5001 format(t2,"Time",t9,"Incremental",t22,"Cumulative",t35,"Rainfall", & - t45,"Infiltration",t59,"Cumulative",t71,"Cumulative",t82, & - "Incremental",/,t2,"Step",t10,"Rainfall",t23,"Rainfall", & - t35,"Intensity",t49,"Rate",t58,"Infiltration",t73,"Runoff", & - t84,"Runoff",/,t12,"(mm)",t25,"(mm)",t36,"(mm/h)",t48, & - "(mm/h)",t62,"(mm)",t74,"(mm)",t85,"(mm)",/) - 5002 format(i5,t12,f5.2,t24,f6.2,t36,f6.2,t47,f7.2,t61,f6.2,t73,f6.2, & - t84,f6.2) +!*** tu Wunused-label: 5000 format(//,"Excess rainfall calculation for day ",i3," of year ", & + !i4," for sub-basin",i4,".",/) +!*** tu Wunused-label: 5001 format(t2,"Time",t9,"Incremental",t22,"Cumulative",t35,"Rainfall", & + !t45,"Infiltration",t59,"Cumulative",t71,"Cumulative",t82, & + !"Incremental",/,t2,"Step",t10,"Rainfall",t23,"Rainfall", & + !t35,"Intensity",t49,"Rate",t58,"Infiltration",t73,"Runoff", & + !t84,"Runoff",/,t12,"(mm)",t25,"(mm)",t36,"(mm/h)",t48, & + !"(mm/h)",t62,"(mm)",t74,"(mm)",t85,"(mm)",/) +!*** tu Wunused-label: 5002 format(i5,t12,f5.2,t24,f6.2,t36,f6.2,t47,f7.2,t61,f6.2,t73,f6.2, & + !t84,f6.2) end subroutine sq_greenampt \ No newline at end of file diff --git a/src/sq_surfst.f90 b/src/sq_surfst.f90 index 594ff55..1478e77 100644 --- a/src/sq_surfst.f90 +++ b/src/sq_surfst.f90 @@ -42,29 +42,29 @@ subroutine sq_surfst j = ihru - if (bsn_cc%gampt == 0) then + if (bsn_cc%gampt == 0) then bsprev = surf_bs(1,j) - surf_bs(1,j) = Max(1.e-6, surf_bs(1,j) + surfq(j)) + surf_bs(1,j) = Max(1.e-6, surf_bs(1,j) + surfq(j)) qday = surf_bs(1,j) * brt(j) surf_bs(1,j) = surf_bs(1,j) - qday - else - bsprev = hhsurf_bs(1,j,time%step) ! lag from previous day J.Jeong 4/06/2009 + else + bsprev = hhsurf_bs(1,j,time%step) ! lag from previous day J.Jeong 4/06/2009 qday = 0. - do k=1,time%step - !! Left-over (previous timestep) + inflow (current timestep) + do k=1,time%step + !! Left-over (previous timestep) + inflow (current timestep) hhsurf_bs(1,j,k) = Max(0., bsprev + hhsurfq(j,k)) - - !! new estimation of runoff and sediment reaching the main channel - hhsurfq(j,k) = hhsurf_bs(1,j,k) * brt(j) - hhsurf_bs(1,j,k) = hhsurf_bs(1,j,k) - hhsurfq(j,k) - - !! lagged at the end of time step - bsprev = hhsurf_bs(1,j,k) + + !! new estimation of runoff and sediment reaching the main channel + hhsurfq(j,k) = hhsurf_bs(1,j,k) * brt(j) + hhsurf_bs(1,j,k) = hhsurf_bs(1,j,k) - hhsurfq(j,k) + + !! lagged at the end of time step + bsprev = hhsurf_bs(1,j,k) !! daily total yield from the HRU - qday = qday + hhsurfq(j,k) - end do - end if + qday = qday + hhsurfq(j,k) + end do + end if return end subroutine sq_surfst \ No newline at end of file diff --git a/src/stmp_solt.f90 b/src/stmp_solt.f90 index 9d4746c..e4f75e3 100644 --- a/src/stmp_solt.f90 +++ b/src/stmp_solt.f90 @@ -132,10 +132,10 @@ subroutine stmp_solt isep = iseptic(j) if (sep(isep)%opt /= 0 .and. time%yrc >= sep(isep)%yr .and. k >= & i_sep(j)) then - if (soil(j)%phys(k)%tmp < 10.) then - soil(j)%phys(k)%tmp = 10. - (10. - soil(j)%phys(k)%tmp) * 0.1 - end if - endif + if (soil(j)%phys(k)%tmp < 10.) then + soil(j)%phys(k)%tmp = 10. - (10. - soil(j)%phys(k)%tmp) * 0.1 + end if + endif end do diff --git a/src/stor_surfstor.f90 b/src/stor_surfstor.f90 index 8c44398..e886367 100644 --- a/src/stor_surfstor.f90 +++ b/src/stor_surfstor.f90 @@ -98,23 +98,23 @@ subroutine stor_surfstor surf_bs(2,j) = surf_bs(2,j) - sedyld(j) else !subdaily time steps, Jaehak Jeong 2011 - sedprev = hhsurf_bs(2,j,time%step) + sedprev = hhsurf_bs(2,j,time%step) - do k=1,time%step - !! Left-over (previous timestep) + inflow (current timestep) + do k=1,time%step + !! Left-over (previous timestep) + inflow (current timestep) hhsurf_bs(2,j,k) = Max(0., sedprev + hhsedy(j,k)) - - !! new estimation of sediment reaching the main channel + + !! new estimation of sediment reaching the main channel hhsedy(j,k) = hhsurf_bs(2,j,k) * brt(j)! tons hhsurf_bs(2,j,k) = hhsurf_bs(2,j,k) - hhsedy(j,k) - - !! lagged at the end of time step - sedprev = hhsurf_bs(2,j,k) + + !! lagged at the end of time step + sedprev = hhsurf_bs(2,j,k) surf_bs(2,j) = Max(1.e-9, surf_bs(2,j) + sedyld(j)) - end do + end do - !! daily total sediment yield from the HRU - sedyld(j) = sum(hhsedy(j,:)) + !! daily total sediment yield from the HRU + sedyld(j) = sum(hhsedy(j,:)) endif surf_bs(13,j) = Max(1.e-6, surf_bs(13,j) + sanyld(j)) @@ -179,7 +179,7 @@ subroutine stor_surfstor surf_bs(53,j) = surf_bs(53,j) + wetqcs(j,1) !seo4 surf_bs(54,j) = surf_bs(54,j) + wetqcs(j,2) !seo3 surf_bs(55,j) = surf_bs(55,j) + wetqcs(j,3) !born - endif + endif !! sedyld(j) = surf_bs(2,j) * brt(j) <--line of code in x 2. fixes sedyld low prob diff --git a/src/structure_set_parms.f90 b/src/structure_set_parms.f90 index 6a9c030..fe0b89c 100644 --- a/src/structure_set_parms.f90 +++ b/src/structure_set_parms.f90 @@ -63,7 +63,7 @@ subroutine structure_set_parms (str_name, istr, j) case ("grassww") hru(j)%lumv%ngrwat = istr if (istr > 0) then - hru(j)%lumv%grwat_i = grwaterway_db(istr)%grwat_i + hru(j)%lumv%grwat_i = 1 hru(j)%lumv%grwat_n = grwaterway_db(istr)%grwat_n hru(j)%lumv%grwat_spcon = grwaterway_db(istr)%grwat_spcon hru(j)%lumv%grwat_d = grwaterway_db(istr)%grwat_d diff --git a/src/surface.f90 b/src/surface.f90 index f7a09be..bc824f9 100644 --- a/src/surface.f90 +++ b/src/surface.f90 @@ -68,8 +68,8 @@ subroutine surface if (qday > 1.e-6 .and. qp_cms > 1.e-6) then call ero_eiusle - !! calculate sediment erosion by rainfall and overland flow - call ero_ovrsed + !! calculate sediment erosion by rainfall and overland flow + call ero_ovrsed end if call ero_cfactor @@ -77,6 +77,6 @@ subroutine surface if (qday < 0.) qday = 0. -1010 format (2(i4,1x),a5,a4,1x,10f8.3) +!*** tu Wunused-label: 1010 format (2(i4,1x),a5,a4,1x,10f8.3) return end subroutine surface \ No newline at end of file diff --git a/src/swift_output.f90 b/src/swift_output.f90 index c42e667..8740586 100644 --- a/src/swift_output.f90 +++ b/src/swift_output.f90 @@ -32,7 +32,7 @@ subroutine swift_output logical :: i_exist ! SWIFT file formats - 201 format (A8,12xA8,46X,*(A16,F2.0,A4,1xA16,F2.0,A4)) ! format of precip.swf headers + 201 format (A8,12xA8,46X,*(A16,F5.1,A4,1xA16,F5.1,A4)) ! format of precip.swf headers 301 format (I8,1xA64,F16.4,8xF16.4) ! format of precip.swf 202 format (A8,30xA8,18X,A8,36xA8,4xA8,218x1A8,6x1A8) ! format of hru_dat.swf headers 302 format (1I8,1x2A48, G16.4 ,1x*(G16.4)) ! format of hru_dat.swf @@ -42,7 +42,7 @@ subroutine swift_output 205 format (7xA16, A16, 10x,*(A16)) ! format of chan_dat.swf headers 305 format (I8, 1x, A16, A16,*(F16.4)) ! format of chan_dat.swf 206 format (4xA8, 1xA8, 20x,*(A16)) ! format of chan_dr.swf headers - 306 format (I8,4xA16, 10xA16,*(F16.4)) ! format of chan_dr.swf +!*** tu Wunused-label: 306 format (I8,4xA16, 10xA16,*(F16.4)) ! format of chan_dr.swf 207 format (A16,1x*(A16)) ! format of aqu_dr.swf headers 208 format (6xA8, 1xA8, 16x,*(A8,6x)) ! format of res_dat.swf headers !209 format (6xA8, 1xA8, 16x,*(A8,6x)) ! format of res_dr.swf headers diff --git a/src/swr_depstor.f90 b/src/swr_depstor.f90 index e39f95d..8762628 100644 --- a/src/swr_depstor.f90 +++ b/src/swr_depstor.f90 @@ -1,4 +1,4 @@ - subroutine swr_depstor + subroutine swr_depstor !! ~ ~ ~ PURPOSE ~ ~ ~ !! this subroutine computes maximum surface depressional storage depth based on @@ -10,22 +10,22 @@ subroutine swr_depstor !! iop(:,:,:) |julian date |date of tillage operation !! mgt_op |none |operation code number !! ranrns_hru(:)|mm |random roughness for a given HRU -!! sol_ori(:) |mm |oriented roughness (ridges) at time of a given tillage operation +!! sol_ori(:) |mm |oriented roughness (ridges) at time of a given tillage operation !! usle_ei |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! stmaxd(:) |mm |maximum surface depressional storage for day in a given HRU +!! stmaxd(:) |mm |maximum surface depressional storage for day in a given HRU !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~ !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! cumei(:) |Mj*mm/ha*hr |cumulative USLE rainfall erosion index since last -!! |tillage operation -!! cumrt(:) |mm H2O |cumulative rainfall since last tillage operation +!! cumei(:) |Mj*mm/ha*hr |cumulative USLE rainfall erosion index since last +!! |tillage operation +!! cumrt(:) |mm H2O |cumulative rainfall since last tillage operation !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~ @@ -42,28 +42,28 @@ subroutine swr_depstor implicit none integer :: j = 0 !none |HRU number - real:: df = 0. !none |oriented and random roughness decay factor - based + real:: df = 0. !none |oriented and random roughness decay factor - based ! |on cumulative EI and cumulative precip_eff - real:: hru_slpp = 0. !% |average percent slope steepness - real:: sol_orgm = 0. !% |percent organic matter content in soil material - !real:: sol_orr !cm |oriented roughness (ridges) after a rain event - real:: sol_rrr = 0. !cm |random roughness after a rain event + real:: hru_slpp = 0. !% |average percent slope steepness + real:: sol_orgm = 0. !% |percent organic matter content in soil material + !real:: sol_orr !cm |oriented roughness (ridges) after a rain event + real:: sol_rrr = 0. !cm |random roughness after a rain event real:: ei = 0. !Mj*mm/ha*hr |USLE rainfall erosion index real :: xx = 0. ! | j = ihru !! Calculate current cummulative erosivity and rainfall - ei = usle_ei*18.7633 - if (itill(j) ==1)then - cumeira(j) = cumeira(j) + ei - cumei(j) = cumeira(j) - ei - cumrai(j) = cumrai(j) + precip_eff - cumrt(j) = cumrai(j) - precip_eff + ei = usle_ei*18.7633 + if (itill(j) ==1)then + cumeira(j) = cumeira(j) + ei + cumei(j) = cumeira(j) - ei + cumrai(j) = cumrai(j) + precip_eff + cumrt(j) = cumrai(j) - precip_eff end if !! Calculate the decay factor df based on %clay and %organic matter or %organic carbon - sol_orgm = soil1(j)%tot(1)%c / 0.58 - xx = (0.943 - 0.07 * soil(j)%phys(1)%clay + 0.0011 * & + sol_orgm = soil1(j)%tot(1)%c / 0.58 + xx = (0.943 - 0.07 * soil(j)%phys(1)%clay + 0.0011 * & soil(j)%phys(1)%clay**2 - 0.67 * sol_orgm + 0.12 * sol_orgm**2) if (xx > 1.) then df = 1. @@ -75,20 +75,20 @@ subroutine swr_depstor !! Determine the current random and oriented roughness using cumei and cumrt and initial !! random and oriented roughness values - sol_rrr = 0.1 * ranrns_hru(j) & - * exp(df*(-0.0009*cumei(j)-0.0007 * cumrt(j))) - -! sol_orr = 0.1*sol_ori(j)* -! & exp(df*(-0.025*(cumei(j)**0.31)-0.0085*(cumrt(j)**0.567))) + sol_rrr = 0.1 * ranrns_hru(j) & + * exp(df*(-0.0009*cumei(j)-0.0007 * cumrt(j))) + +! sol_orr = 0.1*sol_ori(j)* +! & exp(df*(-0.025*(cumei(j)**0.31)-0.0085*(cumrt(j)**0.567))) !! Compute the current maximum depressional storage using percent slope steepness !! and current random and oriented roughness values determined above - hru_slpp = hru(j)%topo%slope*100 -! if(irk=0) then !irk=0 for random rough, and irk=1, for oriented roughness - stmaxd(j)= 0.112*sol_rrr+0.031*sol_rrr**2-0.012*sol_rrr*hru_slpp -! else -! stmaxd(j)= 0.112*sol_orr+0.031*sol_orr**2-0.012*sol_orr*hru_slpp -! endif + hru_slpp = hru(j)%topo%slope*100 +! if(irk=0) then !irk=0 for random rough, and irk=1, for oriented roughness + stmaxd(j)= 0.112*sol_rrr+0.031*sol_rrr**2-0.012*sol_rrr*hru_slpp +! else +! stmaxd(j)= 0.112*sol_orr+0.031*sol_orr**2-0.012*sol_orr*hru_slpp +! endif - return + return end subroutine swr_depstor \ No newline at end of file diff --git a/src/swr_drains.f90 b/src/swr_drains.f90 index e81fb33..636fa8d 100644 --- a/src/swr_drains.f90 +++ b/src/swr_drains.f90 @@ -1,4 +1,4 @@ - subroutine swr_drains + subroutine swr_drains !! ~ ~ ~ PURPOSE ~ ~ ~ !! this subroutine finds the effective lateral hydraulic conductivity @@ -8,7 +8,7 @@ subroutine swr_drains !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! drain_co(:) |mm/day |drainage coefficient -!! ddrain(:) |mm |depth of drain tube from the soil surface +!! ddrain(:) |mm |depth of drain tube from the soil surface !! 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 @@ -105,11 +105,11 @@ subroutine swr_drains if(y1 > soil(j)%phys(j1)%d) then wnan(j1) = 0. else - wnan(j1) = soil(j)%phys(j1)%d - y1 - x = soil(j)%phys(j1)%d - above + wnan(j1) = soil(j)%phys(j1)%d - y1 + x = soil(j)%phys(j1)%d - above if(wnan(j1) > x) wnan(j1) = x - end if - above = soil(j)%phys(j1)%d + end if + above = soil(j)%phys(j1)%d end do sum = 0. deep = 0. @@ -122,27 +122,27 @@ subroutine swr_drains sum = 0. deep = 0.001 do j1=1,soil(j)%nly - sum = sum + soil(j)%ly(j1)%conk * soil(j)%phys(j1)%thick !Daniel 10/09/07 - deep = deep + dg !Daniel 10/09/07 + sum = sum + soil(j)%ly(j1)%conk * soil(j)%phys(j1)%thick !Daniel 10/09/07 + deep = deep + dg !Daniel 10/09/07 end do - cone=sum/deep - else - cone=sum/deep + cone=sum/deep + else + cone=sum/deep end if - !! calculate parameters hdrain and gee1 + !! calculate parameters hdrain and gee1 ad = soil(j)%zmx - hru(j)%lumv%sdr_dep ad = Max (10., ad) - ap = 3.55 - ((1.6 * ad) / hru(j)%sdr%dist) + 2 * & + ap = 3.55 - ((1.6 * ad) / hru(j)%sdr%dist) + 2 * & ((2 / hru(j)%sdr%dist)**2) - if (ad / hru(j)%sdr%dist < 0.3) then + if (ad / hru(j)%sdr%dist < 0.3) then hdrain= ad / (1 + ((ad / hru(j)%sdr%dist) * (((8 / pi) * & - Log(ad / hru(j)%sdr%radius) - ap)))) + Log(ad / hru(j)%sdr%radius) - ap)))) else hdrain = ad !hdrain = (hru(j)%sdr%dist * pi) / (8 * ((log(hru(j)%sdr%dist / & ! hru(j)%sdr%radius)/ log(e)) - 1.15)) - end if + end if !! calculate Kirkham G-Factor, gee k2 = tan((pi * ((2. * ad) - hru(j)%sdr%radius)) / (4. * soil(j)%zmx)) k3 = tan((pi * hru(j)%sdr%radius) / (4. * soil(j)%zmx)) @@ -164,11 +164,11 @@ subroutine swr_drains if (gee > 12.) gee = 12. !! calculate drainage and subirrigation flux section - ! drainage flux for ponded surface + ! drainage flux for ponded surface depth = hru(j)%lumv%sdr_dep + hdrain hdmin = depth - hru(j)%lumv%sdr_dep call swr_depstor ! dynamic stmaxd(j): compute current HRU stmaxd based - ! on cumulative rainfall and cum. intensity + ! 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 !! Determine surface storage for the day in a given HRU (stor) @@ -187,7 +187,7 @@ subroutine swr_drains dflux= (12.56637 * 24.0 * cone* (depth - hdrain + stor)) / (gee * hru(j)%sdr%dist) !eq.10 if (dflux > hru(j)%sdr%drain_co) dflux = hru(j)%sdr%drain_co !eq.11 else -! subirrigation flux +! subirrigation flux em = depth - y1 - hdrain if(em < -1.0) then !! ddranp=ddrain(j)-1.0 @@ -198,15 +198,15 @@ subroutine swr_drains if (abs(dflux) > hru(j)%sdr%pumpcap) then dflux = - hru(j)%sdr%pumpcap * 24.0 end if -! drainage flux - for WT below the surface and for ponded depths < storro (S1) +! 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) / hru(j)%sdr%dist**2 !eq.5 if(dflux > hru(j)%sdr%drain_co) dflux = hru(j)%sdr%drain_co !eq.11 if(dflux < 0.) dflux=0. if(em < 0.) dflux=0. end if - end if - qtile = dflux + end if + qtile = dflux return end subroutine swr_drains \ No newline at end of file diff --git a/src/swr_percmain.f90 b/src/swr_percmain.f90 index 4f8b17f..8089384 100644 --- a/src/swr_percmain.f90 +++ b/src/swr_percmain.f90 @@ -9,15 +9,15 @@ subroutine swr_percmain !! name |units |definition !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ !! new water table depth equations 01/2009 -!! c |none |a factor used to convert airvol to wtd +!! c |none |a factor used to convert airvol to wtd !! dg |mm |soil layer thickness in HRU !! new water table depth equations 01/2009 !! latq(:) |mm H2O |total lateral flow in soil profile for the !! |day in HRU !! lyrtile |mm H2O |drainage tile flow in soil layer for day !! new water table depth equations 01/2009 -!! ne_p |mm/hr |effective porosity in HRU for all soil profile layers -!! ne_w |mm/hr |effective porosity in HRU for soil layers above wtd +!! ne_p |mm/hr |effective porosity in HRU for all soil profile layers +!! ne_w |mm/hr |effective porosity in HRU for soil layers above wtd !! new water table depth equations 01/2009 !! qtile |mm H2O |drainage tile flow in soil profile for the day !! sepday |mm H2O |micropore percolation from soil layer @@ -29,8 +29,8 @@ subroutine swr_percmain !! new water table depth equations 01/2009 !! wt_shall |mm H2O |shallow water table height above bottom of soil profile !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -!! w2 |mm | -!! y1 |mm |dummy variable for wat +!! w2 |mm | +!! y1 |mm |dummy variable for wat !! ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ use hru_module, only : hru, ihru, i_sep, inflpcp, isep, latlyr, latq, lyrtile, qstemm, sepbtm, sepcrktot, sepday, & @@ -68,7 +68,7 @@ subroutine swr_percmain !! initialize water entering first soil layer !! ht1%flo is infiltration from overland flow routing if (ires==0) then - sepday = inflpcp + irrig(j)%applied + ht1%flo !mm + sepday = inflpcp + irrig(j)%applied + ht1%flo / (hru(j)%area_ha * 10.) else sepday = inflpcp + ht1%flo / (hru(j)%area_ha * 10.) endif @@ -77,9 +77,9 @@ subroutine swr_percmain !! calculate crack flow if (bsn_cc%crk == 1) then - call swr_percmacro - sepday = sepday - sepcrktot - endif + call swr_percmacro + sepday = sepday - sepcrktot + endif !back to 4 mm slug for soil routing- keeps moisture above fc slug = 1000. !4. !1000. !this should be an input in parameters.bsn @@ -92,11 +92,11 @@ subroutine swr_percmain !! add water moving into soil layer from overlying layer soil(j)%phys(j1)%st = soil(j)%phys(j1)%st + sepday - !! septic tank inflow to biozone layer J.Jeong - ! STE added to the biozone layer if soil temp is above zero. - if (j1 == i_sep(j) .and. soil(j)%phys(j1)%tmp > 0. .and. & + !! septic tank inflow to biozone layer J.Jeong + ! STE added to the biozone layer if soil temp is above zero. + if (j1 == i_sep(j) .and. soil(j)%phys(j1)%tmp > 0. .and. & sep(isep)%opt /= 0) then - soil(j)%phys(j1)%st = soil(j)%phys(j1)%st + qstemm(j) ! in mm + soil(j)%phys(j1)%st = soil(j)%phys(j1)%st + qstemm(j) ! in mm end if !! determine gravity drained water in layer @@ -124,7 +124,7 @@ subroutine swr_percmain qtile = qtile + lyrtile soil(j)%ly(j1)%flat = latlyr + lyrtile soil(j)%ly(j1)%prk = soil(j)%ly(j1)%prk + sepday - if (latq(j) < 1.e-6) latq(j) = 0. + if (latq(j) < 1.e-6) latq(j) = 0. if (qtile < 1.e-6) qtile = 0. if (soil(j)%ly(j1)%flat < 1.e-6) soil(j)%ly(j1)%flat = 0. end do @@ -157,8 +157,8 @@ subroutine swr_percmain xx = (soil(j)%sw - soil(j)%sumfc) / (yy - soil(j)%sumfc) if (xx > 1.) xx = 1. wt_shall = xx * soil(j)%zmx - wat = soil(j)%zmx - wt_shall - if(wat > soil(j)%zmx) wat = soil(j)%zmx + wat = soil(j)%zmx - wt_shall + if(wat > soil(j)%zmx) wat = soil(j)%zmx end if else !compute water table depth using Daniel"s modifications @@ -167,12 +167,12 @@ subroutine swr_percmain sw_del = soil(j)%swpwt - soil(j)%sw wt_del = sw_del * soil(j)%ly(j1)%vwt soil(j)%wat_tbl = soil(j)%wat_tbl + wt_del - if(soil(j)%wat_tbl > soil(j)%zmx) soil(j)%wat_tbl = soil(j)%zmx - wt_shall = soil(j)%zmx - soil(j)%wat_tbl - soil(j)%swpwt = soil(j)%sw - exit - end if - end do + if(soil(j)%wat_tbl > soil(j)%zmx) soil(j)%wat_tbl = soil(j)%zmx + wt_shall = soil(j)%zmx - soil(j)%wat_tbl + soil(j)%swpwt = soil(j)%sw + exit + end if + end do end if !! drainmod wt_shall equations 10/23/2006 diff --git a/src/swr_percmicro.f90 b/src/swr_percmicro.f90 index 11f1fd4..714b437 100644 --- a/src/swr_percmicro.f90 +++ b/src/swr_percmicro.f90 @@ -92,10 +92,10 @@ subroutine swr_percmicro(ly1) sepday = Max(0., sepday) !! limit maximum seepage from biozone layer below potential perc amount - if(ly1 == i_sep(j).and.sep(isep)%opt ==1) then - sepday = min(sepday,sol_k_sep *24.) - bz_perc(j) = sepday - end if + if(ly1 == i_sep(j).and.sep(isep)%opt ==1) then + sepday = min(sepday,sol_k_sep *24.) + bz_perc(j) = sepday + end if !! switched to linear relationship for dep_imp and seepage if (ly1 == soil(j)%nly) then diff --git a/src/tiles_data_module.f90 b/src/tiles_data_module.f90 index d298177..3ee3fc7 100644 --- a/src/tiles_data_module.f90 +++ b/src/tiles_data_module.f90 @@ -7,7 +7,7 @@ module tiles_data_module real :: depth = 0. !! |mm |depth of drain tube from the soil surface real :: time = 0. !! |hrs |time to drain soil to field capacity real :: lag = 0. !! |hours |drain tile lag time - real :: radius =0. !! |mm effective radius of drains + real :: radius =0. !! |mm effective radius of drains real :: dist = 0. !! |mm |distance between two drain tubes or tiles real :: drain_co = 0. !! |mm/day |drainage coefficient real :: pumpcap = 0. !! |mm/hr |pump capacity (default pump capacity = 1.042mm/hr or 25mm/day) diff --git a/src/time_conc_init.f90 b/src/time_conc_init.f90 index 4488a4d..09e5784 100644 --- a/src/time_conc_init.f90 +++ b/src/time_conc_init.f90 @@ -69,7 +69,7 @@ subroutine time_conc_init !! compute fraction of surface runoff that is reaching the main channel if (time%step > 1) then brt(ihru) = 1.-Exp(-bsn_prm%surlag / (tconc(ihru) / & - (time%dtm / 60.))) !! urban modeling by J.Jeong + (time%dtm / 60.))) !! urban modeling by J.Jeong else brt(ihru) = 1. - Exp(-bsn_prm%surlag / tconc(ihru)) endif diff --git a/src/time_control.f90 b/src/time_control.f90 index c722016..623fccb 100644 --- a/src/time_control.f90 +++ b/src/time_control.f90 @@ -228,13 +228,18 @@ subroutine time_control call conditions (j, id) call actions (j, iob, id) end if - !! have to check every hru for land use change + !! check every hru for land use change if (upd_cond(iupd)%typ == "lu_change") then do j = 1, sp_ob%hru call conditions (j, id) call actions (j, iob, id) end do end if + !! change the land use that is specified + if (upd_cond(iupd)%typ == "lu_change1") then + call conditions (j, id) + call actions (j, iob, id) + end if !end if end do @@ -285,7 +290,7 @@ subroutine time_control if (sp_ob%hru > 0) then do iplt = 1, basin_plants crop_yld_t_ha = bsn_crop_yld(iplt)%yield / (bsn_crop_yld(iplt)%area_ha + 1.e-6) - write (5100,*) time%yrc, iplt, plants_bsn(iplt), bsn_crop_yld(iplt)%area_ha, & + write (5100,*) time%yrc, iplt, plts_bsn(iplt), bsn_crop_yld(iplt)%area_ha, & bsn_crop_yld(iplt)%yield, crop_yld_t_ha bsn_crop_yld_aa(iplt)%area_ha = bsn_crop_yld_aa(iplt)%area_ha + bsn_crop_yld(iplt)%area_ha bsn_crop_yld_aa(iplt)%yield = bsn_crop_yld_aa(iplt)%yield + bsn_crop_yld(iplt)%yield @@ -294,7 +299,7 @@ subroutine time_control crop_yld_t_ha = bsn_crop_yld_aa(iplt)%yield / (bsn_crop_yld_aa(iplt)%area_ha + 1.e-6) bsn_crop_yld_aa(iplt)%area_ha = bsn_crop_yld_aa(iplt)%area_ha / time%yrs_prt bsn_crop_yld_aa(iplt)%yield = bsn_crop_yld_aa(iplt)%yield / time%yrs_prt - write (5101,*) time%yrc, iplt, plants_bsn(iplt), bsn_crop_yld_aa(iplt)%area_ha, & + write (5101,*) time%yrc, iplt, plts_bsn(iplt), bsn_crop_yld_aa(iplt)%area_ha, & bsn_crop_yld_aa(iplt)%yield, crop_yld_t_ha bsn_crop_yld_aa(iplt) = bsn_crop_yld_z end if diff --git a/src/time_module.f90 b/src/time_module.f90 index 5d14317..e8f6df8 100644 --- a/src/time_module.f90 +++ b/src/time_module.f90 @@ -3,7 +3,7 @@ module time_module implicit none !integer :: int_print = 1 !! current interval between daily prints - character (len=25) :: cal_sim = " Original Simulation" + character (len=29) :: cal_sim = " Original Simulation" real :: cal_adj = 0.0 real :: yrs_print = 0. integer, dimension (13) :: ndays = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) diff --git a/src/topography_data_module.f90 b/src/topography_data_module.f90 index d2f0e50..771080d 100644 --- a/src/topography_data_module.f90 +++ b/src/topography_data_module.f90 @@ -4,7 +4,7 @@ module topography_data_module type topography_db character(len=16) :: name = "default" - real :: slope = .02 !! hru_slp(:) |m/m |average slope steepness in HRU + real :: slope = .02 !! hru_slp(:) |m/m |average slope steepness in HRU real :: slope_len = 50. !! slsubbsn(:) |m |average slope length for erosion real :: lat_len = 50. !! slsoil(:) |m |slope length for lateral subsurface flow real :: dis_stream = 100. !! dis_stream(:) |m |average distance to stream diff --git a/src/varinit.f90 b/src/varinit.f90 index b0b340d..46c787e 100644 --- a/src/varinit.f90 +++ b/src/varinit.f90 @@ -120,10 +120,10 @@ subroutine varinit vpd = 0. voltot = 0. - !! urban modeling by J.Jeong - sedprev = 0. - ubnrunoff = 0. - irmmdt = 0. + !! urban modeling by J.Jeong + sedprev = 0. + ubnrunoff = 0. + irmmdt = 0. hhsedy = 0. ubntss = 0. wet_seep_day(j)%no3 = 0 diff --git a/src/wallo_demand.f90 b/src/wallo_demand.f90 index dfd40b6..633ee69 100644 --- a/src/wallo_demand.f90 +++ b/src/wallo_demand.f90 @@ -75,7 +75,11 @@ subroutine wallo_demand (iwallo, idmd) j = wallo(iwallo)%dmd(idmd)%ob_num !! if there is demand, use amount from water allocation file if (irrig(j)%demand > 0.) then + if (hru(j)%irr_hmax > 0.) then + wallod_out(iwallo)%dmd(idmd)%dmd_tot = irrig(j)%demand !m3 Irrigation demand based on paddy/wetland target ponding depth Jaehak 2023 + else wallod_out(iwallo)%dmd(idmd)%dmd_tot = wallo(iwallo)%dmd(idmd)%amount * hru(j)%area_ha * 10. !m3 = mm * ha * 10. + endif else wallod_out(iwallo)%dmd(idmd)%dmd_tot = 0. end if diff --git a/src/wallo_withdraw.f90 b/src/wallo_withdraw.f90 index 437230f..0ecc0d3 100644 --- a/src/wallo_withdraw.f90 +++ b/src/wallo_withdraw.f90 @@ -24,7 +24,7 @@ subroutine wallo_withdraw (iwallo, idmd, isrc) real :: avail = 0. !m3 |water available to withdraw from an aquifer real :: extracted = 0. !m3 |water extracted from the aquifer object (gwflow - rtb) real :: dmd_unmet = 0. !m3 |demand that is unmet (gwflow - rtb) - real :: hru_demand = 0. !m3 |demand (copy to pass into gwflow subroutine - rtb) + real :: hru_demand = 0. !m3 |demand (copy to pass into gwflow subroutine - rtb) real :: withdraw = 0. !m3 real :: unmet = 0. !m3 real :: total_dmd = 0. !m3 diff --git a/src/water_allocation_module.f90 b/src/water_allocation_module.f90 index da8ace1..0f8093f 100644 --- a/src/water_allocation_module.f90 +++ b/src/water_allocation_module.f90 @@ -103,29 +103,29 @@ module water_allocation_module type (water_allocation_output), dimension(:), allocatable :: walloa_out !dimension by demand objects type wallo_header - character(len=6) :: day = " jday" - character(len=6) :: mo = " mon" - character(len=6) :: day_mo = " day " - character(len=6) :: yrc = " yr " - character(len=8) :: idmd = " unit " - character(len=16) :: dmd_typ = "dmd_typ " - character(len=16) :: dmd_num = " dmd_num " - character(len=16) :: rcv_typ = "drcv_typ " - character(len=16) :: rcv_num = " rcv_num " + character(len=6) :: day = " jday" + character(len=6) :: mo = " mon" + character(len=6) :: day_mo = " day " + character(len=6) :: yrc = " yr " + character(len=8) :: idmd = " unit " + character(len=16) :: dmd_typ = "dmd_typ " + character(len=16) :: dmd_num = " dmd_num " + character(len=17) :: rcv_typ = "drcv_typ " + character(len=16) :: rcv_num = " rcv_num " character(len=12) :: src1_obj = " src1_obj " - character(len=12) :: src1_typ = " src1_typ " - character(len=12) :: src1_num = " src1_num " - character(len=15) :: dmd1 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src1_typ = " src1_typ " + character(len=12) :: src1_num = " src1_num " + character(len=15) :: dmd1 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s1out = "src1_withdraw " !! ha-m |withdrawal from source 1 character(len=12) :: s1un = " src1_unmet" !! ha-m |unmet from source 1 - character(len=12) :: src2_typ = " src2_typ " - character(len=12) :: src2_num = " src2_num " - character(len=15) :: dmd2 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src2_typ = " src2_typ " + character(len=12) :: src2_num = " src2_num " + character(len=15) :: dmd2 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s2out = "src2_withdraw " !! ha-m |withdrawal from source 2 character(len=12) :: s2un = " src2_unmet" !! ha-m |unmet from source 2 - character(len=12) :: src3_typ = " src3_typ " - character(len=12) :: src3_num = " src3_num " - character(len=15) :: dmd3 = " demand " !! ha-m |demand - muni or irrigation + character(len=12) :: src3_typ = " src3_typ " + character(len=12) :: src3_num = " src3_num " + character(len=15) :: dmd3 = " demand " !! ha-m |demand - muni or irrigation character(len=15) :: s3out = "src3_withdraw " !! ha-m |withdrawal from source 3 character(len=12) :: s3un = " src3_unmet" !! ha-m |unmet from source 3 @@ -133,31 +133,31 @@ module water_allocation_module type (wallo_header) :: wallo_hdr type wallo_header_units - character (len=8) :: day = " " - character (len=8) :: mo = " " - character (len=8) :: day_mo = " " - character (len=8) :: yrc = " " - character (len=8) :: idmd = " " - character (len=16) :: dmd_typ = " " - character (len=16) :: dmd_num = " " - character (len=16) :: rcv_typ = " " - character (len=16) :: rcv_num = " " + character (len=8) :: day = " " + character (len=8) :: mo = " " + character (len=8) :: day_mo = " " + character (len=8) :: yrc = " " + character (len=8) :: idmd = " " + character (len=16) :: dmd_typ = " " + character (len=16) :: dmd_num = " " + character (len=16) :: rcv_typ = " " + character (len=16) :: rcv_num = " " character (len=12) :: src1_obj = " " - character (len=12) :: src1_typ = " " - character (len=8) :: src1_num = " " + character (len=12) :: src1_typ = " " + character (len=8) :: src1_num = " " character (len=15) :: dmd1 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s1out = "m^3 " !! ha-m |withdrawal from source 1 + character (len=15) :: s1out = "m^3 " !! ha-m |withdrawal from source 1 character (len=9) :: s1un = "m^3 " !! ha-m |unmet from source 1 - character (len=15) :: src2_typ = " " - character (len=15) :: src2_num = " " + character (len=15) :: src2_typ = " " + character (len=15) :: src2_num = " " character (len=15) :: dmd2 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s2out = "m^3 " !! ha-m |withdrawal from source 2 - character (len=10) :: s2un = "m^3 " !! ha-m |unmet from source 2 - character (len=15) :: src3_typ = " " - character (len=15) :: src3_num = " " + character (len=15) :: s2out = "m^3 " !! ha-m |withdrawal from source 2 + character (len=15) :: s2un = "m^3 " !! ha-m |unmet from source 2 + character (len=15) :: src3_typ = " " + character (len=15) :: src3_num = " " character (len=15) :: dmd3 = "m^3 " !! ha-m |demand - muni or irrigation - character (len=15) :: s3out = "m^3 " !! ha-m |withdrawal from source 3 - character (len=10) :: s3un = "m^3 " !! ha-m |unmet from source 3 + character (len=15) :: s3out = "m^3 " !! ha-m |withdrawal from source 3 + character (len=15) :: s3un = "m^3 " !! ha-m |unmet from source 3 end type wallo_header_units type (wallo_header_units) :: wallo_hdr_units diff --git a/src/water_allocation_read.f90 b/src/water_allocation_read.f90 index 56a80a5..fd4b442 100644 --- a/src/water_allocation_read.f90 +++ b/src/water_allocation_read.f90 @@ -116,7 +116,7 @@ subroutine water_allocation_read allocate (walloy_out(iwro)%dmd(i)%src(num_objs)) allocate (walloa_out(iwro)%dmd(i)%src(num_objs)) - !! for hru irrigtion, need to xwalk with irrigation demand decision table + !! for hru irrigation, need to xwalk with irrigation demand decision table if (wallo(iwro)%dmd(i)%ob_typ == "hru") then !! xwalk with lum decision table do idb = 1, db_mx%dtbl_lum diff --git a/src/wet_cs.f90 b/src/wet_cs.f90 index 0b5258f..b959b7c 100644 --- a/src/wet_cs.f90 +++ b/src/wet_cs.f90 @@ -87,11 +87,11 @@ subroutine wet_cs(icmd, icon, ihru) !rtb cs !constituent mass settling to bottom of wetland if(ics == 1) then v_settle = res_cs_data(icon)%v_seo4 - elseif(ics == 2) then + elseif(ics == 2) then v_settle = res_cs_data(icon)%v_seo3 - elseif(ics == 3) then + elseif(ics == 3) then v_settle = res_cs_data(icon)%v_born - endif + endif cs_settle = (cs_conc_beg/1000.) * v_settle * (wet_wat_d(ihru)%area_ha*10000.) !kg if(cs_settle > mass_avail) then cs_settle = mass_avail !take remaining diff --git a/src/wet_initial.f90 b/src/wet_initial.f90 index 01d13b7..6d41cba 100644 --- a/src/wet_initial.f90 +++ b/src/wet_initial.f90 @@ -31,15 +31,14 @@ subroutine wet_initial (iihru) iweir = wet_ob(iihru)%iweir if (iprop > 0) then - ihyd = wet_dat(iprop)%hyd - !if (wet_hyd(ihyd)%k > 0.) then - hru(iihru)%wet_hc = wet_hyd(ihyd)%k !mm/hr + !if (wet_hyd(iihru)%k > 0.) then + hru(iihru)%wet_hc = wet_hyd(iihru)%k !mm/hr !else ! hru(iihru)%wet_hc = soil(iihru)%phys(1)%k !endif !! ha*mm*10. => m**3 - assume entire hru is wet and don't use fractional inputs (for simplicity) - wet_ob(iihru)%evol = hru(iihru)%area_ha * wet_hyd(iihru)%edep * 10. ! * wet_hyd(ihyd)%esa - wet_ob(iihru)%pvol = hru(iihru)%area_ha * wet_hyd(iihru)%pdep * 10. ! * wet_hyd(ihyd)%psa + wet_ob(iihru)%evol = hru(iihru)%area_ha * wet_hyd(iihru)%edep * 10. ! * wet_hyd(iihru)%esa + wet_ob(iihru)%pvol = hru(iihru)%area_ha * wet_hyd(iihru)%pdep * 10. ! * wet_hyd(iihru)%psa wet_ob(iihru)%psa = wet_hyd(iihru)%psa * hru(iihru)%area_ha wet_ob(iihru)%esa = wet_hyd(iihru)%esa * hru(iihru)%area_ha !! set initial weir height to principal depth - m @@ -47,7 +46,7 @@ subroutine wet_initial (iihru) wet_ob(iihru)%weir_hgt = res_weir(iweir)%h !m weir height wet_ob(iihru)%weir_wid = res_weir(iweir)%w !m, weir width !update pvol/evol according to weir height for paddy weir discharge. Jaehak 2023 - wet_ob(iihru)%pvol = hru(iihru)%area_ha * wet_ob(iihru)%weir_hgt * 10.**4 ! m3 + wet_ob(iihru)%pvol = hru(iihru)%area_ha * res_weir(iweir)%h * 10.**4 ! m3 if (wet_ob(iihru)%evol < wet_ob(iihru)%pvol*1.2) then wet_ob(iihru)%evol = wet_ob(iihru)%pvol * 1.2 endif @@ -111,16 +110,16 @@ subroutine wet_initial (iihru) !! wetland on hru - solve quadratic to find new depth wet_wat_d(iihru)%area_ha = 0. if (wet(iihru)%flo > 0.) then - x1 = wet_hyd(ihyd)%bcoef ** 2 + 4. * wet_hyd(ihyd)%ccoef * (1. - wet(iihru)%flo / wet_ob(iihru)%pvol) + x1 = wet_hyd(iihru)%bcoef ** 2 + 4. * wet_hyd(iihru)%ccoef * (1. - wet(iihru)%flo / wet_ob(iihru)%pvol) if (x1 < 1.e-6) then wet_h = 0. else - wet_h1 = (-wet_hyd(ihyd)%bcoef - sqrt(x1)) / (2. * wet_hyd(ihyd)%ccoef) - wet_h = wet_h1 + wet_hyd(ihyd)%bcoef + wet_h1 = (-wet_hyd(iihru)%bcoef - sqrt(x1)) / (2. * wet_hyd(iihru)%ccoef) + wet_h = wet_h1 + wet_hyd(iihru)%bcoef end if - wet_fr = (1. + wet_hyd(ihyd)%acoef * wet_h) + wet_fr = (1. + wet_hyd(iihru)%acoef * wet_h) wet_fr = min(wet_fr,1.) - wet_wat_d(iihru)%area_ha = hru(iihru)%area_ha * wet_hyd(ihyd)%psa * wet_fr + wet_wat_d(iihru)%area_ha = hru(iihru)%area_ha * wet_hyd(iihru)%psa * wet_fr end if end if diff --git a/src/wet_irrp.f90 b/src/wet_irrp.f90 index bb0e2c8..10c263a 100644 --- a/src/wet_irrp.f90 +++ b/src/wet_irrp.f90 @@ -9,6 +9,7 @@ subroutine wet_irrp() use aquifer_module use mgt_operations_module use hru_module, only : hru, ihru + use climate_module implicit none @@ -24,7 +25,7 @@ subroutine wet_irrp() wsa1 = hru(j)%area_ha * 10. !! store initial values - irrig(j)%demand = max(0., hru(j)%irr_hmax - wet_ob(j)%depth*1000.) * wsa1 !m3 + irrig(j)%demand = max(0., hru(j)%irr_hmax - wet_ob(j)%depth*1000. - w%precip) * wsa1 !m3 rto = 0. if (.not. allocated(ob(j)%ru)) then @@ -89,7 +90,8 @@ subroutine wet_irrp() if (aqu_d(isrc)%stor > 0.001) then rto = min(0.99, irrig(j)%demand / aqu_d(isrc)%stor) ! ratio of water removed from aquifer volume end if - irrig(j)%water%flo = rto * aqu_d(isrc)%flo ! organics in irrigation water + ! irrig(j)%water%flo = rto * aqu_d(isrc)%flo ! organics in irrigation water + irrig(j)%water%flo = rto * aqu_d(isrc)%stor ! organics in irrigation water Jaehak 2024 cs_irr(isrc) = rto * cs_aqu(isrc) ! constituents in irrigation water aqu_d(isrc)%stor = (1. - rto) * aqu_d(isrc)%stor ! remainder stays in aquifer cs_aqu(isrc) = (1. - rto) * cs_aqu(isrc) diff --git a/src/wet_read.f90 b/src/wet_read.f90 index 6ddbc4a..efc1c49 100644 --- a/src/wet_read.f90 +++ b/src/wet_read.f90 @@ -132,6 +132,8 @@ subroutine wet_read do ised = 1, db_mx%res_sed if (res_sed(ised)%name == wet_dat_c(isstor)%sed) then wet_prm(i)%sed = res_sed(ised) + !! d50 -micro meters + wet_prm(i)%sed_stlr_co = exp(-0.184 * wet_prm(i)%sed%d50) wet_dat(isstor)%sed = ised exit end if diff --git a/src/wetland_control.f90 b/src/wetland_control.f90 index a4a0e58..0c674f7 100644 --- a/src/wetland_control.f90 +++ b/src/wetland_control.f90 @@ -31,6 +31,8 @@ subroutine wetland_control integer :: ires = 0 integer :: j1 = 0 integer :: ii = 0 !none |sub daily time step counter + integer :: ihyd = 0 !none |counter !Jaehak 2024 + integer :: isched = 0 !none |counter !Jaehak 2024 real :: wet_fr = 0. real :: pvol_m3 = 0. real :: evol_m3 = 0. @@ -47,9 +49,12 @@ subroutine wetland_control real :: swst(20) = 0. j = ihru ires = hru(j)%dbs%surf_stor + ihyd = wet_dat(ires)%hyd ised = wet_dat(ires)%sed irel = wet_dat(ires)%release wsa1 = hru(j)%area_ha * 10. + isched = hru(j)%mgt_ops + wet_wat_d(j)%area_ha = hru(j)%area_ha !! zero outgoing flow ht2 = resz @@ -73,7 +78,7 @@ subroutine wetland_control !! add irrigation water to the paddy/wetland storage wet(j)%flo = wet(j)%flo + irrig(j)%applied * wsa1 !m3 - + wet(j)%no3 = wet(j)%no3 + irrig(j)%no3 * irrig(j)%applied * wsa1 * 0.001 !kg wet_wat_d(j)%area_ha = 0. if (wet(j)%flo > 0.) then !paddy is assumed flat !! update wetland surface area - solve quadratic to find new depth @@ -123,17 +128,21 @@ subroutine wetland_control swst(j1) = swst(j1) - volex !update soil water endif end do - + !update seepage volume wet_wat_d(j)%seep = max(0., wet_wat_d(j)%seep - volex * wsa1) !m3 - endif - + endif + wet(j)%flo = wet(j)%flo - wet_wat_d(j)%seep wet_wat_d(j)%area_ha = hru(j)%area_ha hru(j)%water_seep = wet_wat_d(j)%seep / wsa1 !mm=m3/(10*ha) ! calculate dissolved nutrient infiltration Jaehak 2022 - seep_rto = wet_wat_d(j)%seep / (wet_wat_d(j)%seep + wet(j)%flo) + if (wet_wat_d(j)%seep + wet(j)%flo > 0.01)then + seep_rto = wet_wat_d(j)%seep / (wet_wat_d(j)%seep + wet(j)%flo) + else + seep_rto = 0. + endif soil1(j)%mn(1)%no3 = soil1(j)%mn(1)%no3 + wet(j)%no3 * seep_rto / hru(j)%area_ha !kg/ha soil1(j)%mn(1)%nh4 = soil1(j)%mn(1)%nh4 + wet(j)%nh3 * seep_rto / hru(j)%area_ha !kg/ha soil1(j)%mp(1)%act = soil1(j)%mp(1)%act + wet(j)%solp * seep_rto / hru(j)%area_ha !kg/ha @@ -159,6 +168,8 @@ subroutine wetland_control !if (hru(j)%wet_fp == "n") then !! calc release from decision table d_tbl => dtbl_res(irel) + wbody => wet(j) + wbody_wb => wet_wat_d(j) pvol_m3 = wet_ob(j)%pvol evol_m3 = wet_ob(j)%evol !if (wet_ob(j)%area_ha > 1.e-6) then @@ -193,21 +204,22 @@ subroutine wetland_control end do end if - !end if wet_ob(j)%depth = wet(j)%flo / wsa1 / 1000. !m !! compute sediment deposition call res_sediment - !!! subtract sediment leaving from reservoir - !wet(j)%sed = wet(j)%sed - ht2%sed - !wet(j)%sil = wet(j)%sil - ht2%sil - !wet(j)%cla = wet(j)%cla - ht2%cla + wet(j)%sed = wbody%sed !t !! perform reservoir nutrient balance call res_nutrient (j) + wet(j)%no3 = wbody%no3 + wet(j)%nh3 = wbody%nh3 + wet(j)%orgn =wbody%orgn + wet(j)%sedp = wbody%sedp + wet(j)%solp = wbody%solp !! perform salt ion constituent balance call wet_salt(icmd,j) @@ -236,10 +248,6 @@ subroutine wetland_control - !write(100100,'(3(I6,","),11(f10.1,","))') time%yrc,time%mo,time%day_mo,w%precip,irrig(j)%applied,hru(j)%water_seep,& - ! weir_hgt*1000,wet(j)%flo/wsa1,ht2%flo/wsa1,soil(j)%sw,wet(j)%sed*1000,ht2%sed*1000,no3ppm,ht2%no3 - !write(*,'(3(I6),11(f10.1))') time%yrc,time%mo,time%day_mo,w%precip,irrig(j)%applied,hru(j)%water_seep,& - ! weir_hgt*1000,wet(j)%flo/wsa1,ht2%flo/wsa1,soil(j)%sw,wet(j)%sed*1000,ht2%sed*1000,wet(j)%no3,ht2%no3 !! perform reservoir pesticide transformations !call res_pest (ires) @@ -267,10 +275,8 @@ subroutine wetland_control !! set inflow and outflow variables for reservoir_output if (time%yrs > pco%nyskip) then - wet_in_d(j) = ht1 + wet_in_d(j) = wet_in_d(j) + ht1 wet_out_d(j) = ht2 - !wet_in_d(j)%flo = wet(j)%flo / 10000. !m^3 -> ha-m - !wet_out_d(j)%flo = wet(j)%flo / 10000. !m^3 -> ha-m end if return diff --git a/src/wetland_output.f90 b/src/wetland_output.f90 index e43828b..af92a79 100644 --- a/src/wetland_output.f90 +++ b/src/wetland_output.f90 @@ -90,6 +90,6 @@ subroutine wetland_output(j) return -100 format (4i6,2i10,2x,a,63e15.4) +100 format (4i6,2i10,2x,a,64e15.4) end subroutine wetland_output \ No newline at end of file