diff --git a/Externals.cfg b/Externals.cfg index a17f8e2ec6..d36ba61489 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -98,4 +98,4 @@ tag = v1.0.8 required = False [externals_description] -schema_version = 1.0.0 +schema_version = 1.0.0 \ No newline at end of file diff --git a/bld/CLMBuildNamelist.pm b/bld/CLMBuildNamelist.pm index 17c46f9bef..031d553703 100755 --- a/bld/CLMBuildNamelist.pm +++ b/bld/CLMBuildNamelist.pm @@ -1576,6 +1576,7 @@ sub process_namelist_inline_logic { setup_logic_glacier($opts, $nl_flags, $definition, $defaults, $nl, $envxml_ref); setup_logic_dynamic_plant_nitrogen_alloc($opts, $nl_flags, $definition, $defaults, $nl, $physv); setup_logic_luna($opts, $nl_flags, $definition, $defaults, $nl, $physv); + setup_logic_hillslope($opts, $nl_flags, $definition, $defaults, $nl); setup_logic_o3_veg_stress_method($opts, $nl_flags, $definition, $defaults, $nl,$physv); setup_logic_hydrstress($opts, $nl_flags, $definition, $defaults, $nl); setup_logic_dynamic_roots($opts, $nl_flags, $definition, $defaults, $nl, $physv); @@ -2682,6 +2683,8 @@ sub setup_logic_do_transient_pfts { $cannot_be_true = "$var cannot be combined with use_cndv"; } elsif (&value_is_true($nl->get_value('use_fates'))) { $cannot_be_true = "$var cannot be combined with use_fates"; + } elsif (&value_is_true($nl->get_value('use_hillslope'))) { + $cannot_be_true = "$var cannot be combined with use_hillslope"; } if ($cannot_be_true) { @@ -2757,6 +2760,8 @@ sub setup_logic_do_transient_crops { # do_transient_crops. However, this hasn't been tested, so to be safe, # we are not allowing this combination for now. $cannot_be_true = "$var has not been tested with FATES, so for now these two options cannot be combined"; + } elsif (&value_is_true($nl->get_value('use_hillslope'))) { + $cannot_be_true = "$var cannot be combined with use_hillslope"; } if ($cannot_be_true) { @@ -2852,6 +2857,8 @@ sub setup_logic_do_transient_lakes { if (&value_is_true($nl->get_value($var))) { if (&value_is_true($nl->get_value('collapse_urban'))) { $log->fatal_error("$var cannot be combined with collapse_urban"); + } elsif (&value_is_true($nl->get_value('use_hillslope'))) { + $log->fatal_error("$var cannot be combined with use_hillslope"); } if ($n_dom_pfts > 0 || $n_dom_landunits > 0 || $toosmall_soil > 0 || $toosmall_crop > 0 || $toosmall_glacier > 0 || $toosmall_lake > 0 || $toosmall_wetland > 0 || $toosmall_urban > 0) { $log->fatal_error("$var cannot be combined with any of the of the following > 0: n_dom_pfts > 0, n_dom_landunit > 0, toosmall_soil > 0._r8, toosmall_crop > 0._r8, toosmall_glacier > 0._r8, toosmall_lake > 0._r8, toosmall_wetland > 0._r8, toosmall_urban > 0._r8"); @@ -2915,6 +2922,8 @@ sub setup_logic_do_transient_urban { if (&value_is_true($nl->get_value($var))) { if (&value_is_true($nl->get_value('collapse_urban'))) { $log->fatal_error("$var cannot be combined with collapse_urban"); + } elsif (&value_is_true($nl->get_value('use_hillslope'))) { + $log->fatal_error("$var cannot be combined with use_hillslope"); } if ($n_dom_pfts > 0 || $n_dom_landunits > 0 || $toosmall_soil > 0 || $toosmall_crop > 0 || $toosmall_glacier > 0 || $toosmall_lake > 0 || $toosmall_wetland > 0 || $toosmall_urban > 0) { $log->fatal_error("$var cannot be combined with any of the of the following > 0: n_dom_pfts > 0, n_dom_landunit > 0, toosmall_soil > 0._r8, toosmall_crop > 0._r8, toosmall_glacier > 0._r8, toosmall_lake > 0._r8, toosmall_wetland > 0._r8, toosmall_urban > 0._r8"); @@ -3244,12 +3253,8 @@ sub setup_logic_hydrology_switches { add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'use_subgrid_fluxes'); add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'snow_cover_fraction_method'); my $subgrid = $nl->get_value('use_subgrid_fluxes' ); - my $origflag = $nl->get_value('origflag' ); my $h2osfcflag = $nl->get_value('h2osfcflag' ); my $scf_method = $nl->get_value('snow_cover_fraction_method'); - if ( $origflag == 1 && &value_is_true($subgrid) ) { - $log->fatal_error("if origflag is ON, use_subgrid_fluxes can NOT also be on!"); - } if ( $h2osfcflag == 1 && ! &value_is_true($subgrid) ) { $log->fatal_error("if h2osfcflag is ON, use_subgrid_fluxes can NOT be off!"); } @@ -3273,9 +3278,6 @@ sub setup_logic_hydrology_switches { if ( defined($use_vic) && defined($lower) && (&value_is_true($use_vic)) && $lower != 3 && $lower != 4) { $log->fatal_error( "If use_vichydro is on -- lower_boundary_condition can only be table or aquifer" ); } - if ( defined($origflag) && defined($use_vic) && (&value_is_true($use_vic)) && $origflag == 1 ) { - $log->fatal_error( "If use_vichydro is on -- origflag can NOT be equal to 1" ); - } if ( defined($h2osfcflag) && defined($lower) && $h2osfcflag == 0 && $lower != 4 ) { $log->fatal_error( "If h2osfcflag is 0 lower_boundary_condition can only be aquifer" ); } @@ -3457,6 +3459,28 @@ sub setup_logic_luna { #------------------------------------------------------------------------------- +sub setup_logic_hillslope { + # + # Hillslope model + # + my ($opts, $nl_flags, $definition, $defaults, $nl) = @_; + + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'use_hillslope' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'downscale_hillslope_meteorology' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'hillslope_head_gradient_method' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'hillslope_transmissivity_method' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'hillslope_pft_distribution_method' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'hillslope_soil_profile_method' ); + add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'use_hillslope_routing', 'use_hillslope'=>$nl_flags->{'use_hillslope'} ); + my $use_hillslope = $nl->get_value('use_hillslope'); + my $use_hillslope_routing = $nl->get_value('use_hillslope_routing'); + if ( (! &value_is_true($use_hillslope)) && &value_is_true($use_hillslope_routing) ) { + $log->fatal_error("Cannot turn on use_hillslope_routing when use_hillslope is off\n" ); + } +} + +#------------------------------------------------------------------------------- + sub setup_logic_hydrstress { # # Plant hydraulic stress model @@ -4185,7 +4209,6 @@ sub setup_logic_soil_resis { add_default($opts, $nl_flags->{'inputdata_rootdir'}, $definition, $defaults, $nl, 'soil_resis_method' ); } -#------------------------------------------------------------------------------- sub setup_logic_canopyfluxes { # @@ -4561,6 +4584,7 @@ sub write_output_files { # CLM component my @groups; + @groups = qw(clm_inparm ndepdyn_nml popd_streams urbantv_streams light_streams soil_moisture_streams lai_streams atm2lnd_inparm lnd2atm_inparm clm_canopyhydrology_inparm cnphenology cropcal_streams @@ -4570,7 +4594,7 @@ sub write_output_files { soilhydrology_inparm luna friction_velocity mineral_nitrogen_dynamics soilwater_movement_inparm rooting_profile_inparm soil_resis_inparm bgc_shared canopyfluxes_inparm aerosol - clmu_inparm clm_soilstate_inparm clm_nitrogen clm_snowhydrology_inparm + clmu_inparm clm_soilstate_inparm clm_nitrogen clm_snowhydrology_inparm hillslope_hydrology_inparm hillslope_properties_inparm cnprecision_inparm clm_glacier_behavior crop_inparm irrigation_inparm surfacealbedo_inparm water_tracers_inparm tillage_inparm); diff --git a/bld/namelist_files/namelist_defaults_ctsm.xml b/bld/namelist_files/namelist_defaults_ctsm.xml index 456d99ac2a..a96453ed93 100644 --- a/bld/namelist_files/namelist_defaults_ctsm.xml +++ b/bld/namelist_files/namelist_defaults_ctsm.xml @@ -609,6 +609,18 @@ attributes from the config_cache.xml file (with keys converted to upper-case). -6.d+2 -6.d+1 + + +.false. +.false. +.false. +.false. +Darcy +LayerSum +Standard +Uniform +.true. + .false. .true. diff --git a/bld/namelist_files/namelist_definition_ctsm.xml b/bld/namelist_files/namelist_definition_ctsm.xml index 3e3735b903..0469af2344 100644 --- a/bld/namelist_files/namelist_definition_ctsm.xml +++ b/bld/namelist_files/namelist_definition_ctsm.xml @@ -800,6 +800,41 @@ LUNA operates on C3 and non-crop vegetation (see vcmax_opt for how other veg is LUNA: Leaf Utilization of Nitrogen for Assimilation + +Toggle to turn on the hillslope model + + + +Toggle to turn on meteorological downscaling in hillslope model + + + +Toggle to turn on surface water routing in the hillslope hydrology model + + + +Method for calculating hillslope saturated head gradient + + + +Method for calculating transmissivity of hillslope columns + + + +Method for distributing pfts across hillslope columns + + + +Method for distributing soil thickness across hillslope columns + + Toggle to turn on the plant hydraulic stress model @@ -2499,12 +2534,6 @@ If surface water is active or not (deprecated -- will be removed) - -Use original CLM4 soil hydraulic properties -(deprecated -- will be removed) - - diff --git a/bld/unit_testers/build-namelist_test.pl b/bld/unit_testers/build-namelist_test.pl index 9b579dd9ce..58b3056ef8 100755 --- a/bld/unit_testers/build-namelist_test.pl +++ b/bld/unit_testers/build-namelist_test.pl @@ -811,21 +811,6 @@ sub cat_and_create_namelistinfile { GLC_TWO_WAY_COUPLING=>"FALSE", phys=>"clm4_5", }, - "-vic with origflag=1" =>{ options=>"-vichydro -envxml_dir .", - namelst=>"origflag=1", - GLC_TWO_WAY_COUPLING=>"FALSE", - phys=>"clm4_5", - }, - "l_bnd=flux with origflag=0"=>{ options=>"-envxml_dir .", - namelst=>"origflag=0, lower_boundary_condition=1", - GLC_TWO_WAY_COUPLING=>"FALSE", - phys=>"clm4_5", - }, - "l_bnd=zflux with origflag=0"=>{ options=>"-envxml_dir .", - namelst=>"origflag=0, lower_boundary_condition=2", - GLC_TWO_WAY_COUPLING=>"FALSE", - phys=>"clm4_5", - }, "bedrock with l_bnc=flux" =>{ options=>"-envxml_dir .", namelst=>"use_bedrock=.true., lower_boundary_condition=1", GLC_TWO_WAY_COUPLING=>"FALSE", diff --git a/cime_config/testdefs/testlist_clm.xml b/cime_config/testdefs/testlist_clm.xml index c915552748..2f7326dd78 100644 --- a/cime_config/testdefs/testlist_clm.xml +++ b/cime_config/testdefs/testlist_clm.xml @@ -3450,4 +3450,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cime_config/testdefs/testmods_dirs/clm/Hillslope/include_user_mods b/cime_config/testdefs/testmods_dirs/clm/Hillslope/include_user_mods new file mode 100644 index 0000000000..fe0e18cf88 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/Hillslope/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/clm/Hillslope/shell_commands b/cime_config/testdefs/testmods_dirs/clm/Hillslope/shell_commands new file mode 100644 index 0000000000..6f3602d2e6 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/Hillslope/shell_commands @@ -0,0 +1,4 @@ +./xmlchange CLM_BLDNML_OPTS="-bgc sp" +DIN_LOC_ROOT=$(./xmlquery --value DIN_LOC_ROOT) +meshfile=$DIN_LOC_ROOT/lnd/clm2/testdata/ESMFmesh_10x15_synthetic_cosphill_1.0.nc +./xmlchange ATM_DOMAIN_MESH=${meshfile},LND_DOMAIN_MESH=${meshfile} diff --git a/cime_config/testdefs/testmods_dirs/clm/Hillslope/user_nl_clm b/cime_config/testdefs/testmods_dirs/clm/Hillslope/user_nl_clm new file mode 100644 index 0000000000..e6d726c860 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/Hillslope/user_nl_clm @@ -0,0 +1,11 @@ +use_hillslope = .true. +use_hillslope_routing = .true. +downscale_hillslope_meteorology = .false. +hillslope_head_gradient_method = 'Darcy' +hillslope_transmissivity_method = 'LayerSum' +hillslope_pft_distribution_method = 'PftLowlandUpland' +hillslope_soil_profile_method = 'Uniform' + +fsurdat = '$DIN_LOC_ROOT/lnd/clm2/testdata/surfdata_10x15_78pfts_simyr2000_synthetic_cosphill_1.2.nc' + +use_ssre = .false. \ No newline at end of file diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeC/include_user_mods b/cime_config/testdefs/testmods_dirs/clm/HillslopeC/include_user_mods new file mode 100644 index 0000000000..fa2e50a80d --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeC/include_user_mods @@ -0,0 +1 @@ +../Hillslope diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeC/user_nl_clm b/cime_config/testdefs/testmods_dirs/clm/HillslopeC/user_nl_clm new file mode 100644 index 0000000000..10450766d0 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeC/user_nl_clm @@ -0,0 +1,7 @@ +! Various hillslope options not exercised by other testmods +use_hillslope_routing = .false. +downscale_hillslope_meteorology = .true. +hillslope_head_gradient_method = 'Kinematic' +hillslope_transmissivity_method = 'Uniform' +hillslope_pft_distribution_method = 'DominantPftUniform' +hillslope_soil_profile_method = 'SetLowlandUpland' diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeD/include_user_mods b/cime_config/testdefs/testmods_dirs/clm/HillslopeD/include_user_mods new file mode 100644 index 0000000000..fa2e50a80d --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeD/include_user_mods @@ -0,0 +1 @@ +../Hillslope diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeD/user_nl_clm b/cime_config/testdefs/testmods_dirs/clm/HillslopeD/user_nl_clm new file mode 100644 index 0000000000..04a2332df7 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeD/user_nl_clm @@ -0,0 +1,3 @@ +! Various hillslope options not exercised by other testmods +hillslope_pft_distribution_method = 'DominantPftLowland' +hillslope_soil_profile_method = 'Linear' diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/include_user_mods b/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/include_user_mods new file mode 100644 index 0000000000..fa2e50a80d --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/include_user_mods @@ -0,0 +1 @@ +../Hillslope diff --git a/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/user_nl_clm b/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/user_nl_clm new file mode 100644 index 0000000000..7be761eccc --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/clm/HillslopeFromFile/user_nl_clm @@ -0,0 +1,2 @@ +hillslope_pft_distribution_method = 'FromFile' +hillslope_soil_profile_method = 'FromFile' diff --git a/cime_config/testdefs/testmods_dirs/clm/oldhyd/user_nl_clm b/cime_config/testdefs/testmods_dirs/clm/oldhyd/user_nl_clm index 351bce0a82..5ef1fc660a 100644 --- a/cime_config/testdefs/testmods_dirs/clm/oldhyd/user_nl_clm +++ b/cime_config/testdefs/testmods_dirs/clm/oldhyd/user_nl_clm @@ -1,4 +1,3 @@ snow_cover_fraction_method = 'NiuYang2007' h2osfcflag = 0 - origflag = 1 use_subgrid_fluxes = .false. diff --git a/src/biogeochem/DryDepVelocity.F90 b/src/biogeochem/DryDepVelocity.F90 index f5968c9aa8..f6a3b857da 100644 --- a/src/biogeochem/DryDepVelocity.F90 +++ b/src/biogeochem/DryDepVelocity.F90 @@ -284,13 +284,13 @@ subroutine depvel_compute( bounds, & if ( n_drydep == 0 ) return - associate( & - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) + associate( & + forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) + forc_solad => atm2lnd_inst%forc_solad_downscaled_col, & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric temperature (Kelvin) forc_q => wateratm2lndbulk_inst%forc_q_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric specific humidity (kg/kg) forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] downscaled surface pressure (Pa) forc_rain => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] downscaled rain rate [mm/s] - h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) @@ -324,7 +324,7 @@ subroutine depvel_compute( bounds, & spec_hum = forc_q(c) rain = forc_rain(c) sfc_temp = forc_t(c) - solar_flux = forc_solad(g,1) + solar_flux = forc_solad(c,1) lat = grc%latdeg(g) lon = grc%londeg(g) clmveg = patch%itype(pi) diff --git a/src/biogeochem/VOCEmissionMod.F90 b/src/biogeochem/VOCEmissionMod.F90 index f1865af3b7..a4bd9dc4d2 100644 --- a/src/biogeochem/VOCEmissionMod.F90 +++ b/src/biogeochem/VOCEmissionMod.F90 @@ -485,7 +485,7 @@ subroutine VOCEmission (bounds, num_soilp, filter_soilp, & !h2osoi_vol => waterstate_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (m3/m3) !h2osoi_ice => waterstate_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice soil content (kg/m3) - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) + forc_solad => atm2lnd_inst%forc_solad_downscaled_col, & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (visible only) forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric pressure (Pa) forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) @@ -557,7 +557,7 @@ subroutine VOCEmission (bounds, num_soilp, filter_soilp, & ! Calculate PAR: multiply w/m2 by 4.6 to get umol/m2/s for par (added 8/14/02) !------------------------ ! SUN: - par_sun = (forc_solad(g,1) + fsun(p) * forc_solai(g,1)) * 4.6_r8 + par_sun = (forc_solad(c,1) + fsun(p) * forc_solai(g,1)) * 4.6_r8 par24_sun = (forc_solad24(p) + fsun24(p) * forc_solai24(p)) * 4.6_r8 par240_sun = (forc_solad240(p) + fsun240(p) * forc_solai240(p)) * 4.6_r8 diff --git a/src/biogeophys/BalanceCheckMod.F90 b/src/biogeophys/BalanceCheckMod.F90 index ff72bcb307..b3efe6e525 100644 --- a/src/biogeophys/BalanceCheckMod.F90 +++ b/src/biogeophys/BalanceCheckMod.F90 @@ -35,6 +35,7 @@ module BalanceCheckMod use landunit_varcon , only : istdlak, istsoil,istcrop,istwet,istice use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use column_varcon , only : icol_road_perv, icol_road_imperv + use clm_varctl , only : use_hillslope_routing ! ! !PUBLIC TYPES: implicit none @@ -215,6 +216,7 @@ subroutine WaterGridcellBalanceSingle(bounds, & ! ! !USES: use subgridAveMod, only: c2g + use LandunitType , only : lun ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds @@ -231,8 +233,8 @@ subroutine WaterGridcellBalanceSingle(bounds, & character(len=5) , intent(in) :: flag ! specifies begwb or endwb ! ! !LOCAL VARIABLES: - integer :: g ! indices - integer :: begc, endc, begg, endg ! bounds + integer :: g, l ! indices + integer :: begc, endc, begl, endl, begg, endg ! bounds real(r8) :: wb_col(bounds%begc:bounds%endc) ! temporary column-level water mass real(r8) :: wb_grc(bounds%begg:bounds%endg) ! temporary grid cell-level water mass real(r8) :: qflx_liq_dynbal_left_to_dribble(bounds%begg:bounds%endg) ! grc liq dynamic land cover change conversion runoff flux @@ -250,6 +252,8 @@ subroutine WaterGridcellBalanceSingle(bounds, & begc = bounds%begc endc = bounds%endc + begl = bounds%begl + endl = bounds%endl begg = bounds%begg endg = bounds%endg @@ -266,6 +270,15 @@ subroutine WaterGridcellBalanceSingle(bounds, & call c2g(bounds, wb_col(begc:endc), wb_grc(begg:endg), & c2l_scale_type='urbanf', l2g_scale_type='unity') + ! add landunit level state variable, convert from (m3) to (kg m-2) + if (use_hillslope_routing) then + do l = begl, endl + g = lun%gridcell(l) + wb_grc(g) = wb_grc(g) + waterstate_inst%stream_water_volume_lun(l) & + *1e3_r8/(grc%area(g)*1.e6_r8) + enddo + endif + ! Call the beginning or ending version of the subroutine according ! to flag value if (flag == 'begwb') then @@ -500,8 +513,9 @@ subroutine BalanceCheck( bounds, & !----------------------------------------------------------------------- associate( & - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (vis=forc_sols , nir=forc_soll ) - forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (vis=forc_solsd, nir=forc_solld) + forc_solad_col => atm2lnd_inst%forc_solad_downscaled_col , & ! Input: [real(r8) (:,:) ] direct beam radiation (vis=forc_sols , nir=forc_soll ) + forc_solad => atm2lnd_inst%forc_solad_not_downscaled_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (vis=forc_sols , nir=forc_soll ) + forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (vis=forc_solsd, nir=forc_solld) forc_rain => wateratm2lnd_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] column level rain rate [mm/s] forc_rain_grc => wateratm2lnd_inst%forc_rain_not_downscaled_grc, & ! Input: [real(r8) (:) ] grid cell-level rain rate [mm/s] forc_snow => wateratm2lnd_inst%forc_snow_downscaled_col , & ! Input: [real(r8) (:) ] column level snow rate [mm/s] @@ -546,6 +560,7 @@ subroutine BalanceCheck( bounds, & qflx_qrgwl_grc => waterlnd2atm_inst%qflx_rofliq_qgwl_grc , & ! Input: [real(r8) (:) ] grid cell-level qflx_surf at glaciers, wetlands, lakes qflx_drain_col => waterflux_inst%qflx_drain_col , & ! Input: [real(r8) (:) ] column level sub-surface runoff (mm H2O /s) qflx_drain_grc => waterlnd2atm_inst%qflx_rofliq_qsub_grc , & ! Input: [real(r8) (:) ] grid cell-level drainage (mm H20 /s) + qflx_streamflow_grc => waterlnd2atm_inst%qflx_rofliq_stream_grc, & ! Input: [real(r8) (:) ] streamflow [mm H2O/s] qflx_ice_runoff_col => waterlnd2atm_inst%qflx_ice_runoff_col , & ! Input: [real(r8) (:) ] column level solid runoff from snow capping and from excess ice in soil (mm H2O /s) qflx_ice_runoff_grc => waterlnd2atm_inst%qflx_rofice_grc , & ! Input: [real(r8) (:) ] grid cell-level solid runoff from snow capping and from excess ice in soil (mm H2O /s) qflx_sl_top_soil => waterflux_inst%qflx_sl_top_soil_col , & ! Input: [real(r8) (:) ] liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) @@ -725,6 +740,15 @@ subroutine BalanceCheck( bounds, & - qflx_snwcp_discarded_ice_grc(g)) * dtime end do + ! add landunit level flux variable, convert from (m3/s) to (kg m-2 s-1) + if (use_hillslope_routing) then + ! output water flux from streamflow (+) + do g = bounds%begg, bounds%endg + errh2o_grc(g) = errh2o_grc(g) & + + qflx_streamflow_grc(g) * dtime + enddo + endif + errh2o_max_val = maxval(abs(errh2o_grc(bounds%begg:bounds%endg))) ! BUG(rgk, 2021-04-13, ESCOMP/CTSM#1314) Temporarily bypassing gridcell-level check with use_fates_planthydro until issue 1314 is resolved @@ -883,8 +907,8 @@ subroutine BalanceCheck( bounds, & ! level because of interactions between columns and since a separate check is done ! in the urban radiation module if (.not. lun%urbpoi(l)) then - errsol(p) = fsa(p) + fsr(p) & - - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2)) + errsol(p) = fsa(p) + fsr(p) & + - (forc_solad_col(c,1) + forc_solad_col(c,2) + forc_solai(g,1) + forc_solai(g,2)) else errsol(p) = spval end if diff --git a/src/biogeophys/CMakeLists.txt b/src/biogeophys/CMakeLists.txt index 3cf5e0eaf0..2ffc346670 100644 --- a/src/biogeophys/CMakeLists.txt +++ b/src/biogeophys/CMakeLists.txt @@ -8,6 +8,7 @@ list(APPEND clm_sources CanopyStateType.F90 EnergyFluxType.F90 GlacierSurfaceMassBalanceMod.F90 + HillslopeHydrologyUtilsMod.F90 HumanIndexMod.F90 InfiltrationExcessRunoffMod.F90 IrrigationMod.F90 diff --git a/src/biogeophys/HillslopeHydrologyMod.F90 b/src/biogeophys/HillslopeHydrologyMod.F90 new file mode 100644 index 0000000000..b2866df679 --- /dev/null +++ b/src/biogeophys/HillslopeHydrologyMod.F90 @@ -0,0 +1,1148 @@ +module HillslopeHydrologyMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Read geomorphological parameters for hillslope columns + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc, iam + use abortutils , only : endrun + use clm_varctl , only : iulog + use clm_varctl , only : use_hillslope_routing + use decompMod , only : bounds_type + use clm_varcon , only : rpi + use HillslopeHydrologyUtilsMod, only : HillslopeSoilThicknessProfile_linear + + ! !PUBLIC TYPES: + implicit none + + private + save + + ! !PUBLIC MEMBER FUNCTIONS: + public hillslope_properties_init + public InitHillslope + public SetHillslopeSoilThickness + public HillslopeSoilThicknessProfile + public HillslopeSetLowlandUplandPfts + public HillslopeDominantLowlandPft + public HillslopePftFromFile + public HillslopeStreamOutflow + public HillslopeUpdateStreamWater + + integer, public :: pft_distribution_method ! Method for distributing pfts across hillslope columns + integer, public :: soil_profile_method ! Method for varying soil thickness across hillslope columns + + ! Streamflow methods + integer, public, parameter :: streamflow_manning = 0 + ! Pft distribution methods + integer, public, parameter :: pft_standard = 0 + integer, public, parameter :: pft_from_file = 1 + integer, public, parameter :: pft_uniform_dominant_pft = 2 + integer, public, parameter :: pft_lowland_dominant_pft = 3 + integer, public, parameter :: pft_lowland_upland = 4 + + ! PRIVATE + character(len=*), parameter, private :: sourcefile = & + __FILE__ + integer, private, parameter :: soil_profile_uniform = 0 + integer, private, parameter :: soil_profile_from_file = 1 + integer, private, parameter :: soil_profile_set_lowland_upland = 2 + integer, private, parameter :: soil_profile_linear = 3 + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine hillslope_properties_init(NLFilename) + ! + ! DESCRIPTION + ! read in hillslope hydrology veg/soil properties namelist variables + ! + ! !USES: + use abortutils , only : endrun + use fileutils , only : getavu, relavu + use spmdMod , only : mpicom, masterproc + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use clm_nlUtilsMod , only : find_nlgroup_name + + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: NLFilename ! Namelist filename + !---------------------------------------------------------------------- + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + character(len=*), parameter :: nmlname = 'hillslope_properties_inparm' + character(*), parameter :: subName = "('read_hillslope_properties_namelist')" + ! Default values for namelist + character(len=50) :: hillslope_pft_distribution_method = 'Standard' ! pft distribution method string + character(len=50) :: hillslope_soil_profile_method = 'Uniform' ! soil thickness distribution method string + !----------------------------------------------------------------------- + +! MUST agree with name in namelist and read statement + namelist /hillslope_properties_inparm/ & + hillslope_pft_distribution_method, & + hillslope_soil_profile_method + + ! Read hillslope hydrology namelist + if (masterproc) then + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'hillslope_properties_inparm', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=hillslope_properties_inparm,iostat=nml_error) + if (nml_error /= 0) then + call endrun(subname // ':: ERROR reading hillslope properties namelist') + end if + else + call endrun(subname // ':: ERROR reading hillslope properties namelist') + end if + close(nu_nml) + call relavu( nu_nml ) + + if ( trim(hillslope_pft_distribution_method) == 'Standard' ) then + pft_distribution_method = pft_standard + else if ( trim(hillslope_pft_distribution_method) == 'FromFile' ) then + pft_distribution_method = pft_from_file + else if ( trim(hillslope_pft_distribution_method) == 'DominantPftUniform') then + pft_distribution_method = pft_uniform_dominant_pft + else if ( trim(hillslope_pft_distribution_method) == 'DominantPftLowland') then + pft_distribution_method = pft_lowland_dominant_pft + else if ( trim(hillslope_pft_distribution_method) == 'PftLowlandUpland') then + pft_distribution_method = pft_lowland_upland + else + call endrun(msg="ERROR bad value for hillslope_pft_distribution_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + if ( trim(hillslope_soil_profile_method) == 'Uniform' ) then + soil_profile_method = soil_profile_uniform + else if ( trim(hillslope_soil_profile_method) == 'FromFile' ) then + soil_profile_method = soil_profile_from_file + else if ( trim(hillslope_soil_profile_method) == 'SetLowlandUpland' ) then + soil_profile_method = soil_profile_set_lowland_upland + else if ( trim(hillslope_soil_profile_method) == 'Linear') then + soil_profile_method = soil_profile_linear + else + call endrun(msg="ERROR bad value for hillslope_soil_profile_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + end if + + call shr_mpi_bcast(pft_distribution_method, mpicom) + call shr_mpi_bcast(soil_profile_method, mpicom) + + if (masterproc) then + + write(iulog,*) ' ' + write(iulog,*) 'hillslope_properties settings:' + write(iulog,*) ' hillslope_pft_distribution_method = ',hillslope_pft_distribution_method + write(iulog,*) ' hillslope_soil_profile_method = ',hillslope_soil_profile_method + + end if + + end subroutine hillslope_properties_init + + !----------------------------------------------------------------------- + subroutine check_aquifer_layer() + ! + ! !DESCRIPTION: + ! Check whether use_hillslope and use_aquifer_layer are both set + ! The use of use_hillslope is implied by the call to this function + ! in InitHillslope, but explicitly compare here for clarity. + ! + ! !USES: + use clm_varctl , only : use_hillslope + use SoilWaterMovementMod , only : use_aquifer_layer + if (use_hillslope .and. use_aquifer_layer()) then + write(iulog,*) ' ERROR: use_hillslope and use_aquifer_layer may not be used simultaneously' + call endrun(msg=' ERROR: use_hillslope and use_aquifer_layer cannot both be set to true' // & + errMsg(sourcefile, __LINE__)) + end if + + end subroutine check_aquifer_layer + + !----------------------------------------------------------------------- + + subroutine InitHillslope(bounds,fsurdat) + ! + ! !DESCRIPTION: + ! Initialize hillslope geomorphology from input dataset + ! + ! !USES: + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use clm_varctl , only : nhillslope, max_columns_hillslope + use spmdMod , only : masterproc + use fileutils , only : getfil + use clm_varcon , only : spval, ispval, grlnd + use landunit_varcon , only : istsoil + use subgridWeightsMod , only : compute_higher_order_weights + use ncdio_pio + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: fsurdat ! surface data file name + integer, pointer :: ihillslope_in(:,:) ! read in - integer + integer, pointer :: ncolumns_hillslope_in(:) ! read in number of columns + integer, allocatable :: ncolumns_hillslope(:) ! number of hillslope columns + integer, allocatable :: hill_ndx(:,:) ! hillslope index + integer, allocatable :: col_ndx(:,:) ! column index + integer, allocatable :: col_dndx(:,:) ! downhill column index + integer, allocatable :: hill_pftndx(:,:) ! hillslope pft index [] + integer, allocatable :: col_pftndx(:) ! hillslope column pft index [] + real(r8), pointer :: fhillslope_in(:,:) ! read in - float + real(r8), allocatable :: pct_hillslope(:,:) ! percent of landunit occupied by hillslope + real(r8), allocatable :: hill_slope(:,:) ! hillslope slope [m/m] + real(r8), allocatable :: hill_aspect(:,:) ! hillslope azimuth [radians] + real(r8), allocatable :: hill_area(:,:) ! hillslope area [m2] + real(r8), allocatable :: hill_dist(:,:) ! hillslope length [m] + real(r8), allocatable :: hill_width(:,:) ! hillslope width [m] + real(r8), allocatable :: hill_elev(:,:) ! hillslope height [m] + real(r8), allocatable :: hill_bedrock(:,:) ! hillslope bedrock depth [m] + real(r8), pointer :: fstream_in(:) ! read in - 1D - float + + type(file_desc_t) :: ncid ! netcdf id + logical :: readvar ! check whether variable on file + character(len=256) :: locfn ! local filename + integer :: ierr ! error code + integer :: c, l, g, i, j, ci, nh ! indices + + real(r8) :: ncol_per_hillslope(nhillslope) ! number of columns per hillslope + real(r8) :: hillslope_area(nhillslope) ! area of hillslope + real(r8) :: nhill_per_landunit(nhillslope) ! total number of each representative hillslope per landunit + + character(len=*), parameter :: subname = 'InitHillslope' + + !----------------------------------------------------------------------- + + ! consistency check + call check_aquifer_layer() + + ! Open surface dataset to read in data below + + call getfil (fsurdat, locfn, 0) + call ncd_pio_openfile (ncid, locfn, 0) + + allocate( & + ncolumns_hillslope(bounds%begl:bounds%endl), & + pct_hillslope(bounds%begl:bounds%endl,nhillslope), & + hill_ndx (bounds%begl:bounds%endl,max_columns_hillslope), & + col_ndx (bounds%begl:bounds%endl,max_columns_hillslope), & + col_dndx (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_slope (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_aspect (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_area (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_dist (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_width (bounds%begl:bounds%endl,max_columns_hillslope), & + hill_elev (bounds%begl:bounds%endl,max_columns_hillslope), & + col_pftndx (bounds%begc:bounds%endc), & + stat=ierr) + + allocate(ncolumns_hillslope_in(bounds%begg:bounds%endg)) + + call ncd_io(ncid=ncid, varname='nhillcolumns', flag='read', data=ncolumns_hillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: nhillcolumns not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + ncolumns_hillslope(l) = ncolumns_hillslope_in(g) + ! vegetated landunits having nonzero hillslope columns and nonzero weight + if (lun%wtgcell(l) > 0._r8 .and. lun%itype(l) == istsoil .and. ncolumns_hillslope_in(g) > 0) then + do c = lun%coli(l), lun%colf(l) + col%is_hillslope_column(c) = .true. + enddo + end if + enddo + deallocate(ncolumns_hillslope_in) + + allocate(fhillslope_in(bounds%begg:bounds%endg,nhillslope)) + + call ncd_io(ncid=ncid, varname='pct_hillslope', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: pct_hillslope not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + pct_hillslope(l,:) = fhillslope_in(g,:) + enddo + deallocate(fhillslope_in) + + allocate(ihillslope_in(bounds%begg:bounds%endg,max_columns_hillslope)) + + call ncd_io(ncid=ncid, varname='hillslope_index', flag='read', data=ihillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_index not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_ndx(l,:) = ihillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='column_index', flag='read', data=ihillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: column_index not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + col_ndx(l,:) = ihillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='downhill_column_index', flag='read', data=ihillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: downhill_column_index not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + col_dndx(l,:) = ihillslope_in(g,:) + enddo + deallocate(ihillslope_in) + + allocate(fhillslope_in(bounds%begg:bounds%endg,max_columns_hillslope)) + call ncd_io(ncid=ncid, varname='hillslope_slope', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_slope not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_slope(l,:) = fhillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_aspect', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_aspect not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_aspect(l,:) = fhillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_area', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_area not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_area(l,:) = fhillslope_in(g,:) + enddo + call ncd_io(ncid=ncid, varname='hillslope_distance', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_length not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_dist(l,:) = fhillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_width', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_width not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_width(l,:) = fhillslope_in(g,:) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_elevation', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_height not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_elev(l,:) = fhillslope_in(g,:) + enddo + + deallocate(fhillslope_in) + + allocate(ihillslope_in(bounds%begg:bounds%endg,max_columns_hillslope)) + call ncd_io(ncid=ncid, varname='hillslope_pftndx', flag='read', data=ihillslope_in, dim1name=grlnd, readvar=readvar) + if (readvar) then + allocate(hill_pftndx (bounds%begl:bounds%endl,max_columns_hillslope), stat=ierr) + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + hill_pftndx(l,:) = ihillslope_in(g,:) + enddo + end if + + deallocate(ihillslope_in) + + if (use_hillslope_routing) then + allocate(fstream_in(bounds%begg:bounds%endg)) + + call ncd_io(ncid=ncid, varname='hillslope_stream_depth', flag='read', data=fstream_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_stream_depth not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + lun%stream_channel_depth(l) = fstream_in(g) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_stream_width', flag='read', data=fstream_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_stream_width not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + lun%stream_channel_width(l) = fstream_in(g) + enddo + + call ncd_io(ncid=ncid, varname='hillslope_stream_slope', flag='read', data=fstream_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: hillslope_stream_slope not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + lun%stream_channel_slope(l) = fstream_in(g) + enddo + + deallocate(fstream_in) + end if + + ! Set hillslope hydrology column level variables + ! This needs to match how columns set up in subgridMod + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + if (lun%itype(l) == istsoil) then + + ! map external column index to internal column index + do c = lun%coli(l), lun%colf(l) + ! ci should span [1:nhillcolumns(l)] + ci = c-lun%coli(l)+1 + + if (col_dndx(l,ci) <= -999) then + ! lowermost column of hillslope has no downstream neighbor + col%cold(c) = ispval + else + ! relative separation should be the same + col%cold(c) = c + (col_dndx(l,ci) - col_ndx(l,ci)) + end if + enddo + + do c = lun%coli(l), lun%colf(l) + ci = c-lun%coli(l)+1 + + col%hillslope_ndx(c) = hill_ndx(l,ci) + + ! Find uphill neighbors (this may not actually be useful...) + col%colu(c) = ispval + do i = lun%coli(l), lun%colf(l) + if (c == col%cold(i)) then + col%colu(c) = i + end if + enddo + + ! distance of lower edge of column from hillslope bottom + col%hill_distance(c) = hill_dist(l,ci) + ! width of lower edge of column + col%hill_width(c) = hill_width(l,ci) + ! mean elevation of column relative to gridcell mean elevation + col%hill_elev(c) = hill_elev(l,ci) + ! mean along-hill slope of column + col%hill_slope(c) = hill_slope(l,ci) + ! area of column + col%hill_area(c) = hill_area(l,ci) + ! azimuth of column + col%hill_aspect(c) = hill_aspect(l,ci) + ! pft index of column + if ( allocated(hill_pftndx) ) then + col_pftndx(c) = hill_pftndx(l,ci) + end if + + enddo + + ! Calculate total hillslope area on landunit and + ! number of columns in each hillslope + ncol_per_hillslope(:)= 0._r8 + hillslope_area(:) = 0._r8 + do c = lun%coli(l), lun%colf(l) + nh = col%hillslope_ndx(c) + if (nh > 0) then + ncol_per_hillslope(nh) = ncol_per_hillslope(nh) + 1 + hillslope_area(nh) = hillslope_area(nh) + col%hill_area(c) + end if + enddo + + if (use_hillslope_routing) then + + ! Total area occupied by each hillslope (m2) is + ! grc%area(g)*1.e6*lun%wtgcell(l)*pct_hillslope(l,nh)*0.01 + ! Number of representative hillslopes per landunit + ! is the total area divided by individual area + ! include factor of 0.5 because a channel is shared by ~2 hillslopes + + lun%stream_channel_number(l) = 0._r8 + do nh = 1, nhillslope + if (hillslope_area(nh) > 0._r8) then + nhill_per_landunit(nh) = grc%area(g)*1.e6_r8*lun%wtgcell(l) & + *pct_hillslope(l,nh)*0.01/hillslope_area(nh) + + lun%stream_channel_number(l) = lun%stream_channel_number(l) & + + 0.5_r8 * nhill_per_landunit(nh) + end if + enddo + + ! Calculate steam channel length + ! Total length of stream banks is individual widths + ! times number of hillslopes per landunit + ! include factor of 0.5 because a channel is shared by ~2 hillslopes + lun%stream_channel_length(l) = 0._r8 + do c = lun%coli(l), lun%colf(l) + if (col%cold(c) == ispval) then + lun%stream_channel_length(l) = lun%stream_channel_length(l) & + + col%hill_width(c) * 0.5_r8 * nhill_per_landunit(col%hillslope_ndx(c)) + end if + enddo + end if + + ! if missing hillslope information on surface dataset, + ! call endrun + if (ncolumns_hillslope(l) > 0 .and. sum(hillslope_area) == 0._r8 .and. masterproc) then + write(iulog,*) 'Problem with input data: nhillcolumns is non-zero, but hillslope area is zero' + write(iulog,*) 'Check surface data for gridcell at (lon/lat): ', grc%londeg(g),grc%latdeg(g) + call endrun( 'ERROR:: sum of hillslope areas is zero.'//errmsg(sourcefile, __LINE__) ) + end if + + ! Recalculate column weights using input areas + ! The higher order weights will be updated in a subsequent reweight_wrapup call + do c = lun%coli(l), lun%colf(l) + nh = col%hillslope_ndx(c) + if (col%is_hillslope_column(c)) then + col%wtlunit(c) = (col%hill_area(c)/hillslope_area(nh)) & + * (pct_hillslope(l,nh)*0.01_r8) + end if + enddo + end if + enddo ! end of landunit loop + + deallocate(ncolumns_hillslope,pct_hillslope,hill_ndx,col_ndx,col_dndx, & + hill_slope,hill_area,hill_dist, & + hill_width,hill_elev,hill_aspect) + + ! Modify pft distributions + ! this may require modifying subgridMod/natveg_patch_exists + ! to ensure patch exists in every gridcell + if (pft_distribution_method == pft_from_file) then + call HillslopePftFromFile(bounds,col_pftndx) + else if (pft_distribution_method == pft_lowland_dominant_pft) then + ! Specify different pfts for uplands / lowlands + call HillslopeDominantLowlandPft(bounds) + else if (pft_distribution_method == pft_lowland_upland) then + ! example usage: + ! upland_ivt = 13 ! c3 non-arctic grass + ! lowland_ivt = 7 ! broadleaf deciduous tree + call HillslopeSetLowlandUplandPfts(bounds,lowland_ivt=7,upland_ivt=13) + else if (masterproc .and. .not. (pft_distribution_method == pft_standard .or. pft_distribution_method ==pft_uniform_dominant_pft)) then + call endrun( 'ERROR:: unrecognized hillslope_pft_distribution_method'//errmsg(sourcefile, __LINE__) ) + end if + + if ( allocated(hill_pftndx) ) then + deallocate(hill_pftndx) + deallocate(col_pftndx) + end if + + ! Update higher order weights and check that weights sum to 1 + call compute_higher_order_weights(bounds) + + call ncd_pio_closefile(ncid) + + end subroutine InitHillslope + + !----------------------------------------------------------------------- + + subroutine SetHillslopeSoilThickness(bounds,fsurdat,soil_depth_lowland_in,soil_depth_upland_in) + ! + ! !DESCRIPTION: + ! Set hillslope column nbedrock values + ! + ! !USES: + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use clm_varctl , only : nhillslope, max_columns_hillslope + use clm_varcon , only : zmin_bedrock, zisoi + use clm_varpar , only : nlevsoi + use spmdMod , only : masterproc + use fileutils , only : getfil + use clm_varcon , only : spval, ispval, grlnd + use ncdio_pio + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: fsurdat ! surface data file name + real(r8), intent(in), optional :: soil_depth_lowland_in + real(r8), intent(in), optional :: soil_depth_upland_in + real(r8), pointer :: fhillslope_in(:,:) ! read in - float + + type(file_desc_t) :: ncid ! netcdf id + logical :: readvar ! check whether variable on file + character(len=256) :: locfn ! local filename + integer :: ierr ! error code + integer :: c, l, g, j, ci ! indices + + real(r8) :: soil_depth_lowland + real(r8) :: soil_depth_upland + real(r8), parameter :: soil_depth_lowland_default = 8.0 + real(r8), parameter :: soil_depth_upland_default = 8.0 + character(len=*), parameter :: subname = 'SetHillslopeSoilThickness' + + !----------------------------------------------------------------------- + + if (soil_profile_method==soil_profile_from_file) then + + ! Open surface dataset to read in data below + call getfil (fsurdat, locfn, 0) + call ncd_pio_openfile (ncid, locfn, 0) + + allocate(fhillslope_in(bounds%begg:bounds%endg,max_columns_hillslope)) + call ncd_io(ncid=ncid, varname='hillslope_bedrock_depth', flag='read', data=fhillslope_in, dim1name=grlnd, readvar=readvar) + if (masterproc .and. .not. readvar) then + call endrun( 'ERROR:: soil_profile_method = "FromFile", but hillslope_bedrock not found on surface data set.'//errmsg(sourcefile, __LINE__) ) + end if + do l = bounds%begl,bounds%endl + g = lun%gridcell(l) + do c = lun%coli(l), lun%colf(l) + if (col%is_hillslope_column(c) .and. col%active(c)) then + ci = c-lun%coli(l)+1 + do j = 1,nlevsoi + if (zisoi(j-1) > zmin_bedrock) then + if (zisoi(j-1) < fhillslope_in(g,ci) & + .and. zisoi(j) >= fhillslope_in(g,ci)) then + col%nbedrock(c) = j + end if + end if + enddo + end if + enddo + enddo + deallocate(fhillslope_in) + call ncd_pio_closefile(ncid) + + else if (soil_profile_method==soil_profile_set_lowland_upland & + .or. soil_profile_method==soil_profile_linear) then + + if (present(soil_depth_lowland_in)) then + soil_depth_lowland = soil_depth_lowland_in + else + soil_depth_lowland = soil_depth_lowland_default + end if + + if (present(soil_depth_upland_in)) then + soil_depth_upland = soil_depth_upland_in + else + soil_depth_upland = soil_depth_upland_default + end if + + ! Modify hillslope soil thickness profile + call HillslopeSoilThicknessProfile(bounds,& + soil_profile_method=soil_profile_method,& + soil_depth_lowland_in=soil_depth_lowland,& + soil_depth_upland_in=soil_depth_upland) + + else if (soil_profile_method /= soil_profile_uniform .and. masterproc) then + call endrun( msg=' ERROR: unrecognized hillslope_soil_profile_method'//errMsg(sourcefile, __LINE__)) + + end if + + end subroutine SetHillslopeSoilThickness + + !----------------------------------------------------------------------- + subroutine HillslopeSoilThicknessProfile(bounds,& + soil_profile_method,soil_depth_lowland_in,soil_depth_upland_in) + ! + ! !DESCRIPTION: + ! Modify soil thickness across hillslope by changing + ! col%nbedrock + ! + ! !USES: + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use clm_varcon , only : zmin_bedrock, zisoi + use clm_varpar , only : nlevsoi + use spmdMod , only : masterproc + use fileutils , only : getfil + use clm_varcon , only : spval, ispval, grlnd + use ncdio_pio + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: soil_profile_method + real(r8), intent(in), optional :: soil_depth_lowland_in + real(r8), intent(in), optional :: soil_depth_upland_in + + integer :: c, l, g, i, j + real(r8) :: min_hill_dist, max_hill_dist + real(r8) :: m, b ! linear soil thickness slope/intercept + real(r8) :: soil_depth_col + real(r8) :: soil_depth_lowland + real(r8) :: soil_depth_upland + real(r8), parameter :: soil_depth_lowland_default = 8.0 + real(r8), parameter :: soil_depth_upland_default = 8.0 + + character(len=*), parameter :: subname = 'HillslopeSoilThicknessProfile' + + !----------------------------------------------------------------------- + + if (present(soil_depth_lowland_in)) then + soil_depth_lowland = soil_depth_lowland_in + else + soil_depth_lowland = soil_depth_lowland_default + end if + + if (present(soil_depth_upland_in)) then + soil_depth_upland = soil_depth_upland_in + else + soil_depth_upland = soil_depth_upland_default + end if + + ! Specify lowland/upland soil thicknesses separately + if (soil_profile_method == soil_profile_set_lowland_upland) then + do c = bounds%begc,bounds%endc + if (col%is_hillslope_column(c) .and. col%active(c)) then + if (col%cold(c) /= ispval) then + do j = 1,nlevsoi + if (zisoi(j-1) > zmin_bedrock) then + if (zisoi(j-1) < soil_depth_upland .and. zisoi(j) >= soil_depth_upland) then + col%nbedrock(c) = j + end if + end if + enddo + else + do j = 1,nlevsoi + if (zisoi(j-1) > zmin_bedrock) then + if (zisoi(j-1) < soil_depth_lowland .and. zisoi(j) >= soil_depth_lowland) then + col%nbedrock(c) = j + end if + end if + enddo + end if + end if + end do + ! Linear soil thickness profile + else if (soil_profile_method == soil_profile_linear) then + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland) + else if (masterproc) then + call endrun( 'ERROR:: invalid soil_profile_method.'//errmsg(sourcefile, __LINE__) ) + end if + + end subroutine HillslopeSoilThicknessProfile + + !------------------------------------------------------------------------ + subroutine HillslopeSetLowlandUplandPfts(bounds,lowland_ivt,upland_ivt) + ! + ! !DESCRIPTION: + ! Reassign patch type of each column based on whether a column + ! is identified as a lowland or an upland. + ! Assumes each column has a single pft. + ! In preparation for this reassignment of patch type, only the + ! first patch was given a non-zero weight in surfrd_hillslope + ! + ! !USES + use LandunitType , only : lun + use ColumnType , only : col + use clm_varcon , only : ispval + use clm_varpar , only : natpft_lb + use PatchType , only : patch + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: upland_ivt + integer, intent(in) :: lowland_ivt + ! + ! !LOCAL VARIABLES: + integer :: p,c ! indices + integer :: npatches_per_column + + !------------------------------------------------------------------------ + + do c = bounds%begc, bounds%endc + if (col%is_hillslope_column(c)) then + npatches_per_column = 0 + do p = col%patchi(c), col%patchf(c) + if (col%cold(c) == ispval) then + ! lowland + patch%itype(p) = lowland_ivt + else + ! upland + patch%itype(p) = upland_ivt + end if + ! update mxy as is done in initSubgridMod.add_patch + patch%mxy(p) = patch%itype(p) + (1 - natpft_lb) + + npatches_per_column = npatches_per_column + 1 + enddo + if ((npatches_per_column /= 1) .and. masterproc) then + call endrun( 'ERROR:: number of patches per hillslope column not equal to 1'//errmsg(sourcefile, __LINE__) ) + end if + end if + enddo + + end subroutine HillslopeSetLowlandUplandPfts + + !------------------------------------------------------------------------ + subroutine HillslopeDominantLowlandPft(bounds) + ! + ! !DESCRIPTION: + ! Reassign patch weights of each column based on each gridcell's + ! two most dominant pfts on the input dataset. + ! HillslopeTwoLargestPftIndices is called in surfrd_hillslope to + ! prepare the patch weights for this routine. + ! Assumes each column has a single pft. + ! Use largest weight for lowland, 2nd largest weight for uplands + ! + ! !USES + use LandunitType , only : lun + use ColumnType , only : col + use decompMod , only : get_clump_bounds, get_proc_clumps + use clm_varcon , only : ispval + use PatchType , only : patch + use pftconMod , only : pftcon, ndllf_evr_tmp_tree, nc3_nonarctic_grass, nc4_grass + use array_utils , only : find_k_max_indices + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,c ! indices + integer :: plow, phigh + integer :: max_index(1) + integer, allocatable :: max_indices(:) ! largest weight pft indices + real(r8) :: sum_wtcol, sum_wtlun, sum_wtgrc + + !------------------------------------------------------------------------ + + allocate(max_indices(2)) + do c = bounds%begc,bounds%endc + if (col%is_hillslope_column(c)) then + + ! if only one pft exists, find dominant pft index and set 2nd index to the same value + + if (size(patch%wtcol(col%patchi(c):col%patchf(c))) == 1) then + call find_k_max_indices(patch%wtcol(col%patchi(c):col%patchf(c)),1,1,max_index) + max_indices(1) = max_index(1) + (col%patchi(c) - 1) + max_indices(2) = max_indices(1) + else + call find_k_max_indices(patch%wtcol(col%patchi(c):col%patchf(c)),1,2,max_indices) + max_indices = max_indices + (col%patchi(c) - 1) + end if + + sum_wtcol = sum(patch%wtcol(col%patchi(c):col%patchf(c))) + sum_wtlun = sum(patch%wtlunit(col%patchi(c):col%patchf(c))) + sum_wtgrc = sum(patch%wtgcell(col%patchi(c):col%patchf(c))) + + patch%wtcol(col%patchi(c):col%patchf(c)) = 0._r8 + patch%wtlunit(col%patchi(c):col%patchf(c)) = 0._r8 + patch%wtgcell(col%patchi(c):col%patchf(c)) = 0._r8 + + ! Put the highest stature vegetation on the lowland column + ! non-tree and tree ; place tree on lowland + ! grass and shrub ; place shrub on lowland + ! bare soil and vegetation; place vegetation on lowland + if ((.not. pftcon%is_tree(patch%itype(max_indices(1))) .and. pftcon%is_tree(patch%itype(max_indices(2)))) & + .or. (pftcon%is_grass(patch%itype(max_indices(1))) .and. pftcon%is_shrub(patch%itype(max_indices(2)))) & + .or. (patch%itype(max_indices(1)) == 0)) then + plow = max_indices(2) + phigh = max_indices(1) + else + plow = max_indices(1) + phigh = max_indices(2) + end if + + ! Special cases (subjective) + + ! if NET/BDT assign BDT to lowland + if ((patch%itype(max_indices(1)) == ndllf_evr_tmp_tree) .and. pftcon%is_tree(patch%itype(max_indices(2)))) then + plow = max_indices(2) + phigh = max_indices(1) + end if + ! if C3/C4 assign C4 to lowland + if ((patch%itype(max_indices(1)) == nc4_grass) .and. (patch%itype(max_indices(2)) == nc3_nonarctic_grass)) then + plow = max_indices(1) + phigh = max_indices(2) + end if + if ((patch%itype(max_indices(1)) == nc3_nonarctic_grass) .and. (patch%itype(max_indices(2)) == nc4_grass)) then + plow = max_indices(2) + phigh = max_indices(1) + end if + + if (col%cold(c) == ispval) then + ! lowland column + patch%wtcol(plow) = sum_wtcol + patch%wtlunit(plow) = sum_wtlun + patch%wtgcell(plow) = sum_wtgrc + else + ! upland columns + patch%wtcol(phigh) = sum_wtcol + patch%wtlunit(phigh) = sum_wtlun + patch%wtgcell(phigh) = sum_wtgrc + end if + end if + enddo ! end loop c + deallocate(max_indices) + + end subroutine HillslopeDominantLowlandPft + + !------------------------------------------------------------------------ + subroutine HillslopePftFromFile(bounds,col_pftndx) + ! + ! !DESCRIPTION: + ! Reassign patch type using indices from surface data file + ! Assumes one patch per hillslope column + ! In preparation for this reassignment of patch type, only the + ! first patch was given a non-zero weight in surfrd_hillslope. + ! + ! !USES + use ColumnType , only : col + use PatchType , only : patch + use clm_varpar , only : natpft_lb + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: col_pftndx(:) + ! + ! !LOCAL VARIABLES: + integer :: p,c ! indices + integer :: npatches_per_column + + !------------------------------------------------------------------------ + + do c = bounds%begc, bounds%endc + if (col%is_hillslope_column(c)) then + ! In preparation for this re-weighting of patch type + ! only first patch was given a non-zero weight in surfrd_hillslope + npatches_per_column = 0 + do p = col%patchi(c), col%patchf(c) + patch%itype(p) = col_pftndx(c) + ! update mxy as is done in initSubgridMod.add_patch + patch%mxy(p) = patch%itype(p) + (1 - natpft_lb) + npatches_per_column = npatches_per_column + 1 + enddo + if ((npatches_per_column /= 1) .and. masterproc) then + call endrun( 'ERROR:: number of patches per hillslope column not equal to 1'//errmsg(sourcefile, __LINE__) ) + end if + end if + enddo + + end subroutine HillslopePftFromFile + + !----------------------------------------------------------------------- + subroutine HillslopeStreamOutflow(bounds, & + waterstatebulk_inst, waterfluxbulk_inst,streamflow_method) + ! + ! !DESCRIPTION: + ! Calculate discharge from stream channel + ! + ! !USES: + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use WaterFluxBulkType , only : waterfluxbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use spmdMod , only : masterproc + use clm_varcon , only : spval, ispval, grlnd + use landunit_varcon , only : istsoil + use ncdio_pio + use clm_time_manager , only : get_step_size_real + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: streamflow_method + type(waterstatebulk_type), intent(inout) :: waterstatebulk_inst + type(waterfluxbulk_type), intent(inout) :: waterfluxbulk_inst + + integer :: c, l, g, i, j + integer :: nstep + real(r8) :: dtime ! land model time step (sec) + real(r8) :: cross_sectional_area ! cross sectional area of stream water (m2) + real(r8) :: stream_depth ! depth of stream water (m) + real(r8) :: hydraulic_radius ! cross sectional area divided by wetted perimeter (m) + real(r8) :: flow_velocity ! flow velocity (m/s) + real(r8) :: overbank_area ! area of water above bankfull (m2) + real(r8), parameter :: manning_roughness = 0.03_r8 ! manning roughness + real(r8), parameter :: manning_exponent = 0.667_r8 ! manning exponent + + integer, parameter :: overbank_method = 1 ! method to treat overbank stream storage; 1 = increase dynamic slope, 2 = increase flow area cross section, 3 = remove instantaneously + logical :: active_stream + character(len=*), parameter :: subname = 'HillslopeStreamOutflow' + + !----------------------------------------------------------------------- + associate( & + stream_water_volume => waterstatebulk_inst%stream_water_volume_lun , & ! Input: [real(r8) (:) ] stream water volume (m3) + volumetric_streamflow => waterfluxbulk_inst%volumetric_streamflow_lun & ! Input: [real(r8) (:) ] stream water discharge (m3/s) + ) + + ! Get time step + dtime = get_step_size_real() + + do l = bounds%begl,bounds%endl + volumetric_streamflow(l) = 0._r8 + + ! Check for vegetated landunits having initialized stream channel properties + active_stream = .false. + if (lun%itype(l) == istsoil .and. & + lun%stream_channel_length(l) > 0._r8 .and. & + lun%stream_channel_width(l) > 0._r8) then + active_stream = .true. + end if + + if (lun%active(l) .and. active_stream) then + ! Streamflow calculated from Manning equation + if (streamflow_method == streamflow_manning) then + cross_sectional_area = stream_water_volume(l) & + /lun%stream_channel_length(l) + stream_depth = cross_sectional_area & + /lun%stream_channel_width(l) + hydraulic_radius = cross_sectional_area & + /(lun%stream_channel_width(l) + 2*stream_depth) + + if (hydraulic_radius <= 0._r8) then + volumetric_streamflow(l) = 0._r8 + else + flow_velocity = (hydraulic_radius)**manning_exponent & + * sqrt(lun%stream_channel_slope(l)) & + / manning_roughness + ! overbank flow + if (stream_depth > lun%stream_channel_depth(l)) then + if (overbank_method == 1) then + ! try increasing dynamic slope + volumetric_streamflow(l) = cross_sectional_area * flow_velocity & + *(stream_depth/lun%stream_channel_depth(l)) + else if (overbank_method == 2) then + ! try increasing flow area cross section + overbank_area = (stream_depth -lun%stream_channel_depth(l)) * 30._r8 * lun%stream_channel_width(l) + volumetric_streamflow(l) = (cross_sectional_area + overbank_area) * flow_velocity + else if (overbank_method == 3) then + ! try removing all overbank flow instantly + volumetric_streamflow(l) = cross_sectional_area * flow_velocity & + + (stream_depth-lun%stream_channel_depth(l)) & + *lun%stream_channel_width(l)*lun%stream_channel_length(l)/dtime + else + call endrun( 'ERROR:: invalid overbank_method.'//errmsg(sourcefile, __LINE__) ) + end if + + else + volumetric_streamflow(l) = cross_sectional_area * flow_velocity + end if + + ! scale streamflow by number of channel reaches + volumetric_streamflow(l) = volumetric_streamflow(l) * lun%stream_channel_number(l) + + volumetric_streamflow(l) = max(0._r8,min(volumetric_streamflow(l),stream_water_volume(l)/dtime)) + end if + else + call endrun( 'ERROR:: invalid streamflow_method'//errmsg(sourcefile, __LINE__) ) + end if + end if ! end of istsoil + enddo ! end of loop over landunits + + end associate + + end subroutine HillslopeStreamOutflow + + !----------------------------------------------------------------------- + subroutine HillslopeUpdateStreamWater(bounds, waterstatebulk_inst, & + waterfluxbulk_inst,waterdiagnosticbulk_inst) + ! + ! !DESCRIPTION: + ! Calculate discharge from stream channel + ! + ! !USES: + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use WaterFluxBulkType , only : waterfluxbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use spmdMod , only : masterproc + use clm_varcon , only : spval, ispval, grlnd + use landunit_varcon , only : istsoil + use clm_time_manager, only : get_step_size_real + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + type(waterstatebulk_type), intent(inout) :: waterstatebulk_inst + type(waterfluxbulk_type), intent(inout) :: waterfluxbulk_inst + type(waterdiagnosticbulk_type), intent(inout) :: waterdiagnosticbulk_inst + + integer :: c, l, g, i, j + real(r8) :: qflx_surf_vol ! volumetric surface runoff (m3/s) + real(r8) :: qflx_drain_perched_vol ! volumetric perched saturated drainage (m3/s) + real(r8) :: qflx_drain_vol ! volumetric saturated drainage (m3/s) + real(r8) :: dtime ! land model time step (sec) + logical :: active_stream + + character(len=*), parameter :: subname = 'HillslopeUpdateStreamWater' + + !----------------------------------------------------------------------- + associate( & + stream_water_volume => waterstatebulk_inst%stream_water_volume_lun, & ! Input/Output: [real(r8) (:) ] stream water volume (m3) + volumetric_streamflow => waterfluxbulk_inst%volumetric_streamflow_lun,& ! Input: [real(r8) (:) ] stream water discharge (m3/s) + qflx_drain => waterfluxbulk_inst%qflx_drain_col, & ! Input: [real(r8) (:) ] column level sub-surface runoff (mm H2O /s) + qflx_drain_perched => waterfluxbulk_inst%qflx_drain_perched_col, & ! Input: [real(r8) (:) ] column level sub-surface runoff (mm H2O /s) + qflx_surf => waterfluxbulk_inst%qflx_surf_col, & ! Input: [real(r8) (:) ] total surface runoff (mm H2O /s) + stream_water_depth => waterdiagnosticbulk_inst%stream_water_depth_lun & ! Output: [real(r8) (:) ] stream water depth (m) + ) + + ! Get time step + dtime = get_step_size_real() + + do l = bounds%begl,bounds%endl + + ! Check for vegetated landunits having initialized stream channel properties + active_stream = .false. + if (lun%itype(l) == istsoil .and. & + lun%stream_channel_length(l) > 0._r8 .and. & + lun%stream_channel_width(l) > 0._r8) then + active_stream = .true. + end if + + if (lun%active(l) .and. active_stream) then + g = lun%gridcell(l) + ! the drainage terms are 'net' quantities, so summing over + ! all columns in a hillslope is equivalent to the outflow + ! from the lowland column + do c = lun%coli(l), lun%colf(l) + if (col%is_hillslope_column(c) .and. col%active(c)) then + qflx_surf_vol = qflx_surf(c)*1.e-3_r8 & + *(grc%area(g)*1.e6_r8*col%wtgcell(c)) + qflx_drain_perched_vol = qflx_drain_perched(c)*1.e-3_r8 & + *(grc%area(g)*1.e6_r8*col%wtgcell(c)) + qflx_drain_vol = qflx_drain(c)*1.e-3_r8 & + *(grc%area(g)*1.e6_r8*col%wtgcell(c)) + + stream_water_volume(l) = stream_water_volume(l) & + + (qflx_drain_perched_vol & + + qflx_drain_vol + qflx_surf_vol) * dtime + end if + enddo + stream_water_volume(l) = stream_water_volume(l) & + - volumetric_streamflow(l) * dtime + + ! account for negative drainage (via searchforwater in soilhydrology) + if (stream_water_volume(l) < 0._r8) then + volumetric_streamflow(l) = volumetric_streamflow(l) + stream_water_volume(l)/dtime + stream_water_volume(l) = 0._r8 + end if + + stream_water_depth(l) = stream_water_volume(l) & + /lun%stream_channel_length(l) & + /lun%stream_channel_width(l) + + end if + enddo + + end associate + + end subroutine HillslopeUpdateStreamWater + +end module HillslopeHydrologyMod diff --git a/src/biogeophys/HillslopeHydrologyUtilsMod.F90 b/src/biogeophys/HillslopeHydrologyUtilsMod.F90 new file mode 100644 index 0000000000..299971055c --- /dev/null +++ b/src/biogeophys/HillslopeHydrologyUtilsMod.F90 @@ -0,0 +1,85 @@ +module HillslopeHydrologyUtilsMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Utilities used in HillslopeHydrologyMod + ! + ! !USES: +#include "shr_assert.h" + use decompMod , only : bounds_type + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc, iam + use abortutils , only : endrun + use clm_varctl , only : iulog + + ! !PUBLIC TYPES: + implicit none + + private + save + + real(r8), parameter :: toosmall_distance_default = 1e-6 + + ! !PUBLIC MEMBER FUNCTIONS: + public HillslopeSoilThicknessProfile_linear + +contains + + !------------------------------------------------------------------------ + subroutine HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland, toosmall_distance_in) + ! + ! !DESCRIPTION: + ! Modify soil thickness across hillslope by changing + ! nbedrock according to the "Linear" method + ! + ! !USES: + use LandunitType , only : lun + use ColumnType , only : col + use clm_varpar , only : nlevsoi + use clm_varcon , only : zisoi + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: soil_depth_lowland, soil_depth_upland + real(r8), intent(in), optional :: toosmall_distance_in + ! + ! !LOCAL VARIABLES + real(r8) :: min_hill_dist, max_hill_dist + real(r8) :: toosmall_distance + real(r8) :: soil_depth_col + real(r8) :: m, b + integer :: c, j, l + + if (present(toosmall_distance_in)) then + toosmall_distance = toosmall_distance_in + else + toosmall_distance = toosmall_distance_default + end if + + do l = bounds%begl,bounds%endl + min_hill_dist = minval(col%hill_distance(lun%coli(l):lun%colf(l))) + max_hill_dist = maxval(col%hill_distance(lun%coli(l):lun%colf(l))) + + if (abs(max_hill_dist - min_hill_dist) > toosmall_distance) then + m = (soil_depth_lowland - soil_depth_upland)/ & + (max_hill_dist - min_hill_dist) + else + m = 0._r8 + end if + b = soil_depth_upland + + do c = lun%coli(l), lun%colf(l) + if (col%is_hillslope_column(c) .and. col%active(c)) then + soil_depth_col = m*(max_hill_dist - col%hill_distance(c)) + b + do j = 1,nlevsoi + if ((zisoi(j-1) < soil_depth_col) .and. (zisoi(j) >= soil_depth_col)) then + col%nbedrock(c) = j + exit + end if + enddo + end if + enddo + enddo + end subroutine HillslopeSoilThicknessProfile_linear +end module HillslopeHydrologyUtilsMod \ No newline at end of file diff --git a/src/biogeophys/HydrologyDrainageMod.F90 b/src/biogeophys/HydrologyDrainageMod.F90 index 31ffc817a0..ce5b78e3ff 100644 --- a/src/biogeophys/HydrologyDrainageMod.F90 +++ b/src/biogeophys/HydrologyDrainageMod.F90 @@ -40,7 +40,7 @@ subroutine HydrologyDrainage(bounds, & num_hydrologyc, filter_hydrologyc, & num_urbanc, filter_urbanc, & num_do_smb_c, filter_do_smb_c, & - atm2lnd_inst, glc2lnd_inst, temperature_inst, & + glc2lnd_inst, temperature_inst, & soilhydrology_inst, soilstate_inst, waterstatebulk_inst, & waterdiagnosticbulk_inst, waterbalancebulk_inst, waterfluxbulk_inst, & wateratm2lndbulk_inst, glacier_smb_inst) @@ -52,11 +52,12 @@ subroutine HydrologyDrainage(bounds, & use landunit_varcon , only : istwet, istsoil, istice, istcrop use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv, icol_sunwall, icol_shadewall use clm_varcon , only : denh2o, denice - use clm_varctl , only : use_vichydro + use clm_varctl , only : use_vichydro, use_hillslope, use_hillslope_routing use clm_varpar , only : nlevgrnd, nlevurb use clm_time_manager , only : get_step_size_real, get_nstep - use SoilHydrologyMod , only : CLMVICMap, Drainage, PerchedLateralFlow, LateralFlowPowerLaw + use SoilHydrologyMod , only : CLMVICMap, Drainage, PerchedLateralFlow, SubsurfaceLateralFlow use SoilWaterMovementMod , only : use_aquifer_layer + use HillslopeHydrologyMod, only : streamflow_manning, HillslopeStreamOutflow, HillslopeUpdateStreamWater ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds @@ -66,18 +67,18 @@ subroutine HydrologyDrainage(bounds, & integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points integer , intent(in) :: num_urbanc ! number of column urban points in column filter integer , intent(in) :: filter_urbanc(:) ! column filter for urban points - integer , intent(in) :: num_do_smb_c ! number of columns in which SMB is calculated, in column filter - integer , intent(in) :: filter_do_smb_c(:) ! column filter for bare landwhere SMB is calculated - type(atm2lnd_type) , intent(in) :: atm2lnd_inst + integer , intent(in) :: num_do_smb_c ! number of bareland columns in which SMB is calculated, in column filter + integer , intent(in) :: filter_do_smb_c(:) ! column filter for bare land SMB columns + type(glc2lnd_type) , intent(in) :: glc2lnd_inst type(temperature_type) , intent(in) :: temperature_inst type(soilhydrology_type) , intent(inout) :: soilhydrology_inst type(soilstate_type) , intent(inout) :: soilstate_inst type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst - type(waterbalance_type) , intent(inout) :: waterbalancebulk_inst + type(waterbalance_type) , intent(inout) :: waterbalancebulk_inst type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst - type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst + type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst type(glacier_smb_type) , intent(in) :: glacier_smb_inst ! ! !LOCAL VARIABLES: @@ -112,6 +113,7 @@ subroutine HydrologyDrainage(bounds, & qflx_surf => waterfluxbulk_inst%qflx_surf_col , & ! surface runoff (mm H2O /s) qflx_infl => waterfluxbulk_inst%qflx_infl_col , & ! infiltration (mm H2O /s) qflx_qrgwl => waterfluxbulk_inst%qflx_qrgwl_col , & ! qflx_surf at glaciers, wetlands, lakes + qflx_latflow_out => waterfluxbulk_inst%qflx_latflow_out_col , & ! lateral subsurface flow qflx_runoff => waterfluxbulk_inst%qflx_runoff_col , & ! total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) qflx_runoff_u => waterfluxbulk_inst%qflx_runoff_u_col , & ! Urban total runoff (qflx_drain+qflx_surf) (mm H2O /s) qflx_runoff_r => waterfluxbulk_inst%qflx_runoff_r_col , & ! Rural total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) @@ -135,16 +137,26 @@ subroutine HydrologyDrainage(bounds, & else call PerchedLateralFlow(bounds, num_hydrologyc, filter_hydrologyc, & - num_urbanc, filter_urbanc,& - soilhydrology_inst, soilstate_inst, & - waterstatebulk_inst, waterfluxbulk_inst) - + soilhydrology_inst, soilstate_inst, & + waterstatebulk_inst, waterfluxbulk_inst, & + wateratm2lndbulk_inst) + call SubsurfaceLateralFlow(bounds, & + num_hydrologyc, filter_hydrologyc, & + num_urbanc, filter_urbanc,& + soilhydrology_inst, soilstate_inst, & + waterstatebulk_inst, waterfluxbulk_inst, & + wateratm2lndbulk_inst) + + if (use_hillslope_routing) then + call HillslopeStreamOutflow(bounds,& + waterstatebulk_inst, waterfluxbulk_inst, & + streamflow_method=streamflow_manning) + + call HillslopeUpdateStreamWater(bounds, & + waterstatebulk_inst, waterfluxbulk_inst, & + waterdiagnosticbulk_inst) + endif - call LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & - num_urbanc, filter_urbanc,& - soilhydrology_inst, soilstate_inst, & - waterstatebulk_inst, waterfluxbulk_inst) - endif do j = 1, nlevgrnd @@ -182,6 +194,7 @@ subroutine HydrologyDrainage(bounds, & if (lun%itype(l)==istwet .or. lun%itype(l)==istice) then + qflx_latflow_out(c) = 0._r8 qflx_drain(c) = 0._r8 qflx_drain_perched(c) = 0._r8 qflx_surf(c) = 0._r8 diff --git a/src/biogeophys/SaturatedExcessRunoffMod.F90 b/src/biogeophys/SaturatedExcessRunoffMod.F90 index 309d251460..5643a95394 100644 --- a/src/biogeophys/SaturatedExcessRunoffMod.F90 +++ b/src/biogeophys/SaturatedExcessRunoffMod.F90 @@ -233,10 +233,8 @@ subroutine SaturatedExcessRunoff (this, bounds, num_hydrologyc, filter_hydrology qflx_sat_excess_surf => waterfluxbulk_inst%qflx_sat_excess_surf_col, & ! Output: [real(r8) (:) ] surface runoff due to saturated surface (mm H2O /s) qflx_floodc => waterfluxbulk_inst%qflx_floodc_col , & ! Input: [real(r8) (:) ] column flux of flood water from RTM - qflx_rain_plus_snomelt => waterfluxbulk_inst%qflx_rain_plus_snomelt_col , & ! Input: [real(r8) (:) ] rain plus snow melt falling on the soil (mm/s) + qflx_rain_plus_snomelt => waterfluxbulk_inst%qflx_rain_plus_snomelt_col & ! Input: [real(r8) (:) ] rain plus snow melt falling on the soil (mm/s) - origflag => soilhydrology_inst%origflag , & ! Input: logical - fracice => soilhydrology_inst%fracice_col & ! Input: [real(r8) (:,:) ] fractional impermeability (-) ) ! ------------------------------------------------------------------------ @@ -275,29 +273,14 @@ subroutine SaturatedExcessRunoff (this, bounds, num_hydrologyc, filter_hydrology ! qflx_rain_plus_snomelt in control ! ------------------------------------------------------------------------ - if (origflag == 1) then - if (this%fsat_method == FSAT_METHOD_VIC) then - ! NOTE(wjs, 2017-07-12) I'm not sure if it's the VIC fsat method per se that - ! is incompatible with origflag, or some other aspect of VIC: The original - ! check was for origflag == 1 and use_vichydro, which also appears in error - ! checks elsewhere. - call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(sourcefile, __LINE__)) - end if - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - fcov(c) = (1._r8 - fracice(c,1)) * fsat(c) + fracice(c,1) - qflx_sat_excess_surf(c) = fcov(c) * qflx_rain_plus_snomelt(c) - end do - else - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - ! only send fast runoff directly to streams - qflx_sat_excess_surf(c) = fsat(c) * qflx_rain_plus_snomelt(c) - - ! Set fcov just to have it on the history file - fcov(c) = fsat(c) - end do - end if + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + ! only send fast runoff directly to streams + qflx_sat_excess_surf(c) = fsat(c) * qflx_rain_plus_snomelt(c) + + ! Set fcov just to have it on the history file + fcov(c) = fsat(c) + end do ! ------------------------------------------------------------------------ ! For urban columns, send flood water flux to runoff diff --git a/src/biogeophys/SoilHydrologyMod.F90 b/src/biogeophys/SoilHydrologyMod.F90 index 4bc6a784de..5a4aa50f6e 100644 --- a/src/biogeophys/SoilHydrologyMod.F90 +++ b/src/biogeophys/SoilHydrologyMod.F90 @@ -10,6 +10,7 @@ module SoilHydrologyMod use abortutils , only : endrun use decompMod , only : bounds_type, subgrid_level_column use clm_varctl , only : iulog, use_vichydro + use clm_varcon , only : ispval use clm_varcon , only : denh2o, denice, rpi use clm_varcon , only : pondmx_urban use clm_varpar , only : nlevsoi, nlevgrnd, nlayer, nlayert @@ -31,7 +32,8 @@ module SoilHydrologyMod use TemperatureType , only : temperature_type use LandunitType , only : lun use ColumnType , only : column_type, col - use PatchType , only : patch + use PatchType , only : patch + ! ! !PUBLIC TYPES: implicit none @@ -51,7 +53,7 @@ module SoilHydrologyMod public :: PerchedWaterTable ! Calculate perched water table public :: PerchedLateralFlow ! Calculate lateral flow from perched saturated zone public :: ThetaBasedWaterTable ! Calculate water table from soil moisture state - public :: LateralFlowPowerLaw ! Calculate lateral flow based on power law drainage function + public :: SubsurfaceLateralFlow ! Calculate subsurface lateral flow from saturated zone public :: RenewCondensation ! Misc. corrections public :: CalcIrrigWithdrawals ! Calculate irrigation withdrawals from groundwater by layer public :: WithdrawGroundwaterIrrigation ! Remove groundwater irrigation from unconfined and confined aquifers @@ -63,17 +65,112 @@ module SoilHydrologyMod real(r8) :: perched_baseflow_scalar ! Scalar multiplier for perched base flow rate (kg/m2/s) real(r8) :: e_ice ! Soil ice impedance factor (unitless) end type params_type - type(params_type), private :: params_inst + type(params_type), public :: params_inst !----------------------------------------------------------------------- real(r8), private :: baseflow_scalar = 1.e-2_r8 real(r8), parameter :: tolerance = 1.e-12_r8 ! tolerance for checking whether sublimation is greater than ice in top soil layer + integer, private :: head_gradient_method ! Method for calculating hillslope saturated head gradient + integer, private :: transmissivity_method ! Method for calculating transmissivity of hillslope columns + + ! Head gradient methods + integer, parameter, private :: kinematic = 0 + integer, parameter, private :: darcy = 1 + ! Transmissivity methods + integer, parameter, private :: uniform_transmissivity = 0 + integer, parameter, private :: layersum = 1 + character(len=*), parameter, private :: sourcefile = & __FILE__ contains + !----------------------------------------------------------------------- + subroutine hillslope_hydrology_ReadNML(NLFilename) + ! + ! DESCRIPTION + ! read in hillslope hydrology namelist variables related to + ! subsurface lateral flow + ! + ! !USES: + use abortutils , only : endrun + use fileutils , only : getavu, relavu + use spmdMod , only : mpicom, masterproc + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use clm_nlUtilsMod , only : find_nlgroup_name + + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: NLFilename ! Namelist filename + !-------------------------------------------------------------------- + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + character(len=*), parameter :: nmlname = 'hillslope_hydrology_inparm' + character(*), parameter :: subName = "('hillslope_hydrology_ReadNML')" + character(len=50) :: hillslope_head_gradient_method = 'Darcy' ! head gradient method string + character(len=50) :: hillslope_transmissivity_method = 'LayerSum' ! transmissivity method string + !----------------------------------------------------------------------- + +! MUST agree with name in namelist and read statement + namelist /hillslope_hydrology_inparm/ & + hillslope_head_gradient_method, & + hillslope_transmissivity_method + + ! Default values for namelist + head_gradient_method = darcy + transmissivity_method = layersum + + ! Read hillslope hydrology namelist + if (masterproc) then + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'hillslope_hydrology_inparm', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=hillslope_hydrology_inparm,iostat=nml_error) + if (nml_error /= 0) then + call endrun(subname // ':: ERROR reading hillslope hydrology namelist') + end if + else + call endrun(subname // ':: ERROR reading hillslope hydrology namelist') + end if + close(nu_nml) + call relavu( nu_nml ) + + ! Convert namelist strings to numerical values + if ( trim(hillslope_head_gradient_method) == 'Kinematic' ) then + head_gradient_method = kinematic + else if ( trim(hillslope_head_gradient_method) == 'Darcy' ) then + head_gradient_method = darcy + else + call endrun(msg="ERROR bad value for hillslope_head_gradient_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + if ( trim(hillslope_transmissivity_method) == 'Uniform' ) then + transmissivity_method = uniform_transmissivity + else if ( trim(hillslope_transmissivity_method) == 'LayerSum') then + transmissivity_method = layersum + else + call endrun(msg="ERROR bad value for hillslope_transmissivity_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + endif + + call shr_mpi_bcast(head_gradient_method, mpicom) + call shr_mpi_bcast(transmissivity_method, mpicom) + + if (masterproc) then + + write(iulog,*) ' ' + write(iulog,*) 'hillslope_hydrology lateral flow settings:' + write(iulog,*) ' hillslope_head_gradient_method = ',hillslope_head_gradient_method + write(iulog,*) ' hillslope_transmissivity_method = ',hillslope_transmissivity_method + + endif + + end subroutine hillslope_hydrology_ReadNML + !----------------------------------------------------------------------- subroutine readParams( ncid ) ! @@ -157,6 +254,8 @@ subroutine soilHydReadNML( NLFilename ) end subroutine soilhydReadNML + + !----------------------------------------------------------------------- subroutine SetSoilWaterFractions(bounds, num_hydrologyc, filter_hydrologyc, & soilhydrology_inst, soilstate_inst, waterstatebulk_inst) @@ -193,10 +292,7 @@ subroutine SetSoilWaterFractions(bounds, num_hydrologyc, filter_hydrologyc, & h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) h2osoi_ice => waterstatebulk_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice water (kg/m2) excess_ice => waterstatebulk_inst%excess_ice_col , & ! Input: [real(r8) (:,:) ] excess ice (kg/m2) - - origflag => soilhydrology_inst%origflag , & ! Input: logical - icefrac => soilhydrology_inst%icefrac_col , & ! Output: [real(r8) (:,:) ] - fracice => soilhydrology_inst%fracice_col & ! Output: [real(r8) (:,:) ] fractional impermeability (-) + icefrac => soilhydrology_inst%icefrac_col & ! Output: [real(r8) (:,:) ] ) do j = 1,nlevsoi @@ -210,15 +306,6 @@ subroutine SetSoilWaterFractions(bounds, num_hydrologyc, filter_hydrologyc, & eff_porosity(c,j) = max(0.01_r8,watsat(c,j)-vol_ice(c,j)) icefrac(c,j) = min(1._r8,vol_ice(c,j)/watsat(c,j)) - ! fracice is only used in code with origflag == 1. For this calculation, we use - ! the version of icefrac that was used in this original hydrology code. - if (h2osoi_ice(c,j) == 0._r8) then - ! Avoid possible divide by zero (in case h2osoi_liq(c,j) is also 0) - icefrac_orig = 0._r8 - else - icefrac_orig = min(1._r8,h2osoi_ice(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j))) - end if - fracice(c,j) = max(0._r8,exp(-3._r8*(1._r8-icefrac_orig))- exp(-3._r8))/(1.0_r8-exp(-3._r8)) end do end do @@ -601,7 +688,6 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, & real(r8) :: xs(bounds%begc:bounds%endc) ! water needed to bring soil moisture to watmin (mm) real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevsoi) ! layer thickness (mm) integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) - real(r8) :: rsub_bot(bounds%begc:bounds%endc) ! subsurface runoff - bottom drainage (mm/s) real(r8) :: rsub_top(bounds%begc:bounds%endc) ! subsurface runoff - topographic control (mm/s) real(r8) :: xsi(bounds%begc:bounds%endc) ! excess soil water above saturation at layer i (mm) real(r8) :: rous ! aquifer yield (-) @@ -610,7 +696,6 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, & real(r8) :: s_node ! soil wetness (-) real(r8) :: dzsum ! summation of dzmm of layers below water table (mm) real(r8) :: icefracsum ! summation of icefrac*dzmm of layers below water table (-) - real(r8) :: fracice_rsub(bounds%begc:bounds%endc) ! fractional impermeability of soil layers (-) real(r8) :: ka ! hydraulic conductivity of the aquifer (mm/s) real(r8) :: available_h2osoi_liq ! available soil liquid water in a layer real(r8) :: imped @@ -657,7 +742,6 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, & frost_table => soilhydrology_inst%frost_table_col , & ! Output: [real(r8) (:) ] frost table depth (m) wa => waterstatebulk_inst%wa_col , & ! Output: [real(r8) (:) ] water in the unconfined aquifer (mm) qcharge => soilhydrology_inst%qcharge_col , & ! Input: [real(r8) (:) ] aquifer recharge rate (mm/s) - origflag => soilhydrology_inst%origflag , & ! Input: logical qflx_drain => waterfluxbulk_inst%qflx_drain_col , & ! Output: [real(r8) (:) ] sub-surface runoff (mm H2O /s) qflx_drain_perched => waterfluxbulk_inst%qflx_drain_perched_col , & ! Output: [real(r8) (:) ] perched wt sub-surface runoff (mm H2O /s) @@ -792,8 +876,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, & !=================== water table above frost table ============================= ! if water table is above frost table, do not use topmodel baseflow formulation - if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz & - .and. origflag == 0) then + if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz) then else !=================== water table below frost table ============================= !-- compute possible perched water table *and* groundwater table afterwards @@ -865,7 +948,6 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte real(r8) :: xs(bounds%begc:bounds%endc) ! water needed to bring soil moisture to watmin (mm) real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevsoi) ! layer thickness (mm) integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) - real(r8) :: rsub_bot(bounds%begc:bounds%endc) ! subsurface runoff - bottom drainage (mm/s) real(r8) :: rsub_top(bounds%begc:bounds%endc) ! subsurface runoff - topographic control (mm/s) real(r8) :: fff(bounds%begc:bounds%endc) ! decay factor (m-1) real(r8) :: xsi(bounds%begc:bounds%endc) ! excess soil water above saturation at layer i (mm) @@ -880,7 +962,6 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte real(r8) :: s_node ! soil wetness (-) real(r8) :: dzsum ! summation of dzmm of layers below water table (mm) real(r8) :: icefracsum ! summation of icefrac*dzmm of layers below water table (-) - real(r8) :: fracice_rsub(bounds%begc:bounds%endc) ! fractional impermeability of soil layers (-) real(r8) :: ka ! hydraulic conductivity of the aquifer (mm/s) real(r8) :: dza ! fff*(zwt-z(jwt)) (-) real(r8) :: available_h2osoi_liq ! available soil liquid water in a layer @@ -943,7 +1024,6 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte wa => waterstatebulk_inst%wa_col , & ! Input: [real(r8) (:) ] water in the unconfined aquifer (mm) ice => soilhydrology_inst%ice_col , & ! Input: [real(r8) (:,:) ] soil layer moisture (mm) qcharge => soilhydrology_inst%qcharge_col , & ! Input: [real(r8) (:) ] aquifer recharge rate (mm/s) - origflag => soilhydrology_inst%origflag , & ! Input: logical h2osfcflag => soilhydrology_inst%h2osfcflag , & ! Input: integer qflx_snwcp_liq => waterfluxbulk_inst%qflx_snwcp_liq_col , & ! Output: [real(r8) (:) ] excess liquid h2o due to snow capping (outgoing) (mm H2O /s) [+] @@ -981,11 +1061,8 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) qflx_drain(c) = 0._r8 - rsub_bot(c) = 0._r8 qflx_rsub_sat(c) = 0._r8 rsub_top(c) = 0._r8 - fracice_rsub(c) = 0._r8 - end do ! The layer index of the first unsaturated layer, i.e., the layer right above @@ -1039,8 +1116,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte !=================== water table above frost table ============================= ! if water table is above frost table, do not use topmodel baseflow formulation - if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz & - .and. origflag == 0) then + if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz) then ! compute drainage from perched saturated region wtsub = 0._r8 q_perch = 0._r8 @@ -1130,9 +1206,6 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte qflx_drain_perched(c) = q_perch_max * q_perch & *(frost_table(c) - zwt_perched(c)) - ! no perched water table drainage if using original formulation - if(origflag == 1) qflx_drain_perched(c) = 0._r8 - ! remove drainage from perched saturated layers rsub_top_tot = - qflx_drain_perched(c) * dtime do k = k_perch+1, k_frz @@ -1168,25 +1241,15 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte icefracsum = icefracsum + icefrac(c,j) * dzmm(c,j) end do ! add ice impedance factor to baseflow - if(origflag == 1) then - if (use_vichydro) then - call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(sourcefile, __LINE__)) - else - fracice_rsub(c) = max(0._r8,exp(-3._r8*(1._r8-(icefracsum/dzsum))) & - - exp(-3._r8))/(1.0_r8-exp(-3._r8)) - imped=(1._r8 - fracice_rsub(c)) - rsub_top_max = 5.5e-3_r8 - end if + if (use_vichydro) then + imped=10._r8**(-params_inst%e_ice*min(1.0_r8,ice(c,nlayer)/max_moist(c,nlayer))) + dsmax_tmp(c) = Dsmax(c) * dtime/ secspday !mm/day->mm/dtime + rsub_top_max = dsmax_tmp(c) else - if (use_vichydro) then - imped=10._r8**(-params_inst%e_ice*min(1.0_r8,ice(c,nlayer)/max_moist(c,nlayer))) - dsmax_tmp(c) = Dsmax(c) * dtime/ secspday !mm/day->mm/dtime - rsub_top_max = dsmax_tmp(c) - else - imped=10._r8**(-params_inst%e_ice*(icefracsum/dzsum)) - rsub_top_max = 10._r8 * sin((rpi/180.) * col%topo_slope(c)) - end if - endif + imped=10._r8**(-params_inst%e_ice*(icefracsum/dzsum)) + rsub_top_max = 10._r8 * sin((rpi/180.) * col%topo_slope(c)) + end if + if (use_vichydro) then ! ARNO model for the bottom soil layer (based on bottom soil layer ! moisture from previous time step @@ -1525,7 +1588,7 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & ! Calculate watertable, considering aquifer recharge but no drainage. ! ! !USES: - use clm_varcon , only : pondmx, tfrz, watmin,denice,denh2o + use clm_varcon , only : tfrz, denice, denh2o use column_varcon , only : icol_roof, icol_road_imperv ! ! !ARGUMENTS: @@ -1537,19 +1600,15 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & type(soilhydrology_type) , intent(inout) :: soilhydrology_inst type(soilstate_type) , intent(in) :: soilstate_inst type(temperature_type) , intent(in) :: temperature_inst - type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst - type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(waterstatebulk_type), intent(inout) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst ! ! !LOCAL VARIABLES: - integer :: c,j,fc,i ! indices - real(r8) :: s_y - integer :: k,k_frz,k_perch,k_zwt - real(r8) :: sat_lev - real(r8) :: s1 - real(r8) :: s2 - real(r8) :: m - real(r8) :: b - integer :: sat_flag + integer :: c,j,fc,i ! indices + integer :: k,k_frz,k_perch,k_zwt ! indices + real(r8) :: s1, s2 ! temporary moisture values + real(r8) :: m, b ! slope and intercept + real(r8), parameter :: sat_lev = 0.9 ! saturation value used to identify saturated layers !----------------------------------------------------------------------- associate( & @@ -1564,8 +1623,7 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) zwt => soilhydrology_inst%zwt_col , & ! Output: [real(r8) (:) ] water table depth (m) zwt_perched => soilhydrology_inst%zwt_perched_col , & ! Output: [real(r8) (:) ] perched water table depth (m) - frost_table => soilhydrology_inst%frost_table_col , & ! Output: [real(r8) (:) ] frost table depth (m) - origflag => soilhydrology_inst%origflag & ! Input: logical + frost_table => soilhydrology_inst%frost_table_col & ! Output: [real(r8) (:) ] frost table depth (m) ) ! calculate perched water table location @@ -1594,16 +1652,13 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & !======= water table above frost table =================== ! if water table is above frost table, do nothing - if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz & - .and. origflag == 0) then + if (zwt(c) < frost_table(c) .and. t_soisno(c,k_frz) <= tfrz) then else if (k_frz > 1) then !========== water table below frost table ============ ! locate perched water table from bottom up starting at ! frost table sat_lev is an arbitrary saturation level ! used to determine perched water table - sat_lev = 0.9 - k_perch = 1 do k=k_frz,1,-1 h2osoi_vol(c,k) = h2osoi_liq(c,k)/(dz(c,k)*denh2o) & @@ -1619,7 +1674,7 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & ! and only compute perched water table if frozen if (t_soisno(c,k_frz) > tfrz) k_perch=k_frz - ! if perched water table exists + ! if perched water table exists above frost table, ! interpolate between k_perch and k_perch+1 to find ! perched water table height if (k_frz > k_perch) then @@ -1635,8 +1690,7 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & b=z(c,k_perch+1)-m*s2 zwt_perched(c)=max(0._r8,m*sat_lev+b) endif - - endif !k_frz > k_perch + endif endif end do @@ -1644,48 +1698,53 @@ subroutine PerchedWaterTable(bounds, num_hydrologyc, filter_hydrologyc, & end subroutine PerchedWaterTable -!#4 +!#4 !----------------------------------------------------------------------- - subroutine PerchedLateralFlow(bounds, num_hydrologyc, filter_hydrologyc, & - num_urbanc, filter_urbanc, soilhydrology_inst, soilstate_inst, & - waterstatebulk_inst, waterfluxbulk_inst) + subroutine PerchedLateralFlow(bounds, num_hydrologyc, & + filter_hydrologyc, soilhydrology_inst, soilstate_inst, & + waterstatebulk_inst, waterfluxbulk_inst, wateratm2lndbulk_inst) ! ! !DESCRIPTION: ! Calculate subsurface drainage from perched saturated zone ! ! !USES: use clm_varcon , only : pondmx, tfrz, watmin,rpi, secspday, nlvic - use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv + use LandunitType , only : lun + use landunit_varcon , only : istsoil + use clm_varctl , only : use_hillslope_routing ! ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter - integer , intent(in) :: num_urbanc ! number of column urban points in column filter - integer , intent(in) :: filter_urbanc(:) ! column filter for urban points - integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points - type(soilstate_type) , intent(in) :: soilstate_inst - type(soilhydrology_type) , intent(inout) :: soilhydrology_inst - type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst - type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points + type(soilstate_type) , intent(in) :: soilstate_inst + type(soilhydrology_type) , intent(inout) :: soilhydrology_inst + type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(wateratm2lndbulk_type), intent(in) :: wateratm2lndbulk_inst ! ! !LOCAL VARIABLES: - character(len=32) :: subname = 'PerchedLateralFlow' ! subroutine name - integer :: c,j,fc,i ! indices - real(r8) :: dtime ! land model time step (sec) - real(r8) :: wtsub ! summation of hk*dzmm for layers below water table (mm**2/s) - real(r8) :: h2osoi_vol - real(r8) :: drainage_tot - real(r8) :: drainage_layer - real(r8) :: s_y - integer :: k - integer :: k_frost(bounds%begc:bounds%endc) - integer :: k_perch(bounds%begc:bounds%endc) - real(r8) :: sat_lev - real(r8) :: s1, s2, m, b - real(r8) :: q_perch - real(r8) :: q_perch_max - !----------------------------------------------------------------------- + character(len=32) :: subname = 'PerchedLateralFlowHillslope' ! subroutine name + integer :: c,fc,k,l,g ! indices + real(r8) :: dtime ! land model time step (sec) + real(r8) :: drainage_tot ! total amount of drainage to be removed from the column (mm/s) + real(r8) :: drainage_layer ! amount of drainage to be removed from current layer (mm/s) + real(r8) :: s_y ! specific yield (unitless) + integer :: k_frost(bounds%begc:bounds%endc) ! indices identifying frost table layer + integer :: k_perch(bounds%begc:bounds%endc) ! indices identifying perched water table layer + real(r8) :: wtsub ! temporary variable + real(r8) :: q_perch ! transmissivity (mm2/s) + real(r8) :: q_perch_max ! baseflow coefficient + real(r8) :: stream_water_depth ! depth of water in stream channel (m) + real(r8) :: stream_channel_depth ! depth of stream channel (m) + + real(r8) :: transmis ! transmissivity (m2/s) + real(r8) :: head_gradient ! head gradient (m/m) + real(r8), parameter :: k_anisotropic = 1._r8 ! anisotropy factor + integer :: c0, c_src, c_dst ! indices + real(r8) :: qflx_drain_perched_vol(bounds%begc:bounds%endc) ! volumetric lateral subsurface flow through active layer [m3/s] + real(r8) :: qflx_drain_perched_out(bounds%begc:bounds%endc) ! lateral subsurface flow through active layer [mm/s] associate( & nbedrock => col%nbedrock , & ! Input: [real(r8) (:,:) ] depth to bedrock (m) @@ -1700,7 +1759,11 @@ subroutine PerchedLateralFlow(bounds, num_hydrologyc, filter_hydrologyc, & frost_table => soilhydrology_inst%frost_table_col , & ! Input: [real(r8) (:) ] frost table depth (m) zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) zwt_perched => soilhydrology_inst%zwt_perched_col , & ! Input: [real(r8) (:) ] perched water table depth (m) - + tdepth => wateratm2lndbulk_inst%tdepth_grc , & ! Input: [real(r8) (:) ] depth of water in tributary channels (m) + tdepth_bankfull => wateratm2lndbulk_inst%tdepthmax_grc , & ! Input: [real(r8) (:) ] bankfull depth of tributary channels (m) + stream_water_volume => waterstatebulk_inst%stream_water_volume_lun , & ! Input: [real(r8) (:) ] stream water volume (m3) + + qflx_drain_perched => waterfluxbulk_inst%qflx_drain_perched_col , & ! Output: [real(r8) (:) ] perched wt sub-surface runoff (mm H2O /s) h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) @@ -1716,14 +1779,14 @@ subroutine PerchedLateralFlow(bounds, num_hydrologyc, filter_hydrologyc, & c = filter_hydrologyc(fc) k_frost(c) = nbedrock(c) k_perch(c) = nbedrock(c) - do k = 1, nbedrock(c) + do k = 1,nbedrock(c) if (frost_table(c) >= zi(c,k-1) .and. frost_table(c) < zi(c,k)) then k_frost(c) = k exit endif enddo - do k = 1, nbedrock(c) + do k = 1,nbedrock(c) if (zwt_perched(c) >= zi(c,k-1) .and. zwt_perched(c) < zi(c,k)) then k_perch(c) = k exit @@ -1734,48 +1797,183 @@ subroutine PerchedLateralFlow(bounds, num_hydrologyc, filter_hydrologyc, & ! compute drainage from perched saturated region do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) + l = col%landunit(c) + g = col%gridcell(c) + qflx_drain_perched(c) = 0._r8 + qflx_drain_perched_out(c) = 0._r8 + qflx_drain_perched_vol(c) = 0._r8 - qflx_drain_perched(c) = 0._r8 if (frost_table(c) > zwt_perched(c)) then + ! Hillslope columns + if (col%is_hillslope_column(c) .and. col%active(c)) then + + ! calculate head gradient + + if (head_gradient_method == kinematic) then + ! kinematic wave approximation + head_gradient = col%hill_slope(c) + else if (head_gradient_method == darcy) then + ! darcy's law + if (col%cold(c) /= ispval) then + head_gradient = (col%hill_elev(c)-zwt_perched(c)) & + - (col%hill_elev(col%cold(c))-zwt_perched(col%cold(c))) + head_gradient = head_gradient / (col%hill_distance(c) - col%hill_distance(col%cold(c))) + else + if (use_hillslope_routing) then + stream_water_depth = stream_water_volume(l) & + /lun%stream_channel_length(l)/lun%stream_channel_width(l) + stream_channel_depth = lun%stream_channel_depth(l) + else + stream_water_depth = tdepth(g) + stream_channel_depth = tdepth_bankfull(g) + endif + + ! flow between channel and lowest column + ! bankfull height is defined to be zero + head_gradient = (col%hill_elev(c)-zwt_perched(c)) & + ! ignore overbankfull storage + - max(min((stream_water_depth - stream_channel_depth),0._r8), & + (col%hill_elev(c)-frost_table(c))) + + head_gradient = head_gradient / (col%hill_distance(c)) + + ! head_gradient cannot be negative when channel is empty + if (stream_water_depth <= 0._r8) then + head_gradient = max(head_gradient, 0._r8) + endif + endif + else + call endrun(msg="head_gradient_method must be kinematic or darcy"//errmsg(sourcefile, __LINE__)) + endif - ! specify maximum drainage rate - q_perch_max = params_inst%perched_baseflow_scalar & - * sin(col%topo_slope(c) * (rpi/180._r8)) + ! Determine source and destination columns + if (head_gradient >= 0._r8) then + c_src = c + c_dst = col%cold(c) + else + c_src = col%cold(c) + c_dst = c + endif - wtsub = 0._r8 - q_perch = 0._r8 - do k = k_perch(c), k_frost(c)-1 - q_perch = q_perch + hksat(c,k)*dz(c,k) - wtsub = wtsub + dz(c,k) - end do - if (wtsub > 0._r8) q_perch = q_perch/wtsub + ! Calculate transmissivity of source column + transmis = 0._r8 + + if (transmissivity_method == layersum) then + if (head_gradient_method == kinematic) then + if(k_perch(c_src) < k_frost(c_src)) then + do k = k_perch(c_src), k_frost(c_src)-1 + if(k == k_perch(c_src)) then + transmis = transmis + 1.e-3_r8*hksat(c_src,k)*(zi(c_src,k) - zwt_perched(c_src)) + else + transmis = transmis + 1.e-3_r8*hksat(c_src,k)*dz(c_src,k) + endif + enddo + endif + else if (head_gradient_method == darcy) then + if(c_src == ispval) then + ! lowland, losing stream (c_src == ispval) + ! use hksat of c_dst for transmissivity + transmis = (1.e-3_r8*hksat(c,k_perch(c_dst)))*stream_water_depth + else + ! if k_perch equals k_frost, no perched saturated zone exists + if(k_perch(c_src) < k_frost(c_src)) then + do k = k_perch(c_src), k_frost(c_src)-1 + if(k == k_perch(c_src)) then + transmis = transmis + 1.e-3_r8*hksat(c_src,k)*(zi(c_src,k) - zwt_perched(c_src)) + else + if(c_dst == ispval) then + ! lowland, gaining stream + ! only include layers above stream channel bottom + if ((col%hill_elev(c_src)-z(c_src,k)) > (-stream_channel_depth)) then + + transmis = transmis + 1.e-3_r8*hksat(c_src,k)*dz(c_src,k) + endif + else + ! uplands + ! only include layers above dst water table elevation + if ((col%hill_elev(c_src)-z(c_src,k)) > (col%hill_elev(c_dst) - zwt_perched(c_dst))) then + + transmis = transmis + 1.e-3_r8*hksat(c_src,k)*dz(c_src,k) + endif + endif + endif + enddo + endif + endif + endif + else if (transmissivity_method == uniform_transmissivity) then + ! constant conductivity based on shallowest saturated layer hydraulic conductivity + transmis = (1.e-3_r8*hksat(c_src,k_perch(c_src))) & + *(zi(c_src,k_frost(c_src)) - zwt_perched(c_src) ) + endif - qflx_drain_perched(c) = q_perch_max * q_perch & - *(frost_table(c) - zwt_perched(c)) + ! adjust by 'anisotropy factor' + transmis = k_anisotropic*transmis + + qflx_drain_perched_vol(c) = transmis*col%hill_width(c)*head_gradient + qflx_drain_perched_out(c) = 1.e3_r8*(qflx_drain_perched_vol(c)/col%hill_area(c)) + + else + ! Non-hillslope columns + ! specify maximum drainage rate + q_perch_max = params_inst%perched_baseflow_scalar & + * sin(col%topo_slope(c) * (rpi/180._r8)) + + wtsub = 0._r8 + q_perch = 0._r8 + ! this should be consistent with hillslope and k_perch=k_frost means no + ! saturated zone; should probably change q_perch to tranmis and change + ! units and q_perch_max + do k = k_perch(c), k_frost(c)-1 + q_perch = q_perch + hksat(c,k)*dz(c,k) + wtsub = wtsub + dz(c,k) + end do + if (wtsub > 0._r8) q_perch = q_perch/wtsub + + qflx_drain_perched_out(c) = q_perch_max * q_perch & + *(frost_table(c) - zwt_perched(c)) + endif endif + enddo + ! compute net drainage from perched saturated region + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + ! drainage-out + qflx_drain_perched(c) = qflx_drain_perched(c) + qflx_drain_perched_out(c) + if (col%is_hillslope_column(c) .and. col%active(c)) then + ! drainage-in + if (col%cold(c) /= ispval) then + qflx_drain_perched(col%cold(c)) = & + qflx_drain_perched(col%cold(c)) - & + 1.e3_r8*(qflx_drain_perched_vol(c))/col%hill_area(col%cold(c)) + endif + endif + enddo + ! remove drainage from soil moisture storage do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) ! remove drainage from perched saturated layers - drainage_tot = qflx_drain_perched(c) * dtime - + drainage_tot = qflx_drain_perched(c) * dtime + ! ignore frozen layer (k_frost) do k = k_perch(c), k_frost(c)-1 + s_y = watsat(c,k) & * ( 1. - (1.+1.e3*zwt_perched(c)/sucsat(c,k))**(-1./bsw(c,k))) s_y=max(s_y,params_inst%aq_sp_yield_min) - - if (k == k_perch(c)) then + if (k==k_perch(c)) then drainage_layer=min(drainage_tot,(s_y*(zi(c,k) - zwt_perched(c))*1.e3)) else drainage_layer=min(drainage_tot,(s_y*(dz(c,k))*1.e3)) endif - + drainage_layer=max(drainage_layer,0._r8) drainage_tot = drainage_tot - drainage_layer h2osoi_liq(c,k) = h2osoi_liq(c,k) - drainage_layer + enddo ! if drainage_tot is greater than available water @@ -1886,17 +2084,24 @@ end subroutine ThetaBasedWaterTable !#6 !----------------------------------------------------------------------- - subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & + subroutine SubsurfaceLateralFlow(bounds, & + num_hydrologyc, filter_hydrologyc, & num_urbanc, filter_urbanc,soilhydrology_inst, soilstate_inst, & - waterstatebulk_inst, waterfluxbulk_inst) + waterstatebulk_inst, waterfluxbulk_inst, wateratm2lndbulk_inst) ! ! !DESCRIPTION: ! Calculate subsurface drainage ! ! !USES: - use clm_varcon , only : pondmx, watmin,rpi, secspday, nlvic - use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv - use GridcellType , only : grc + use clm_time_manager , only : get_step_size + use clm_varpar , only : nlevsoi, nlevgrnd, nlayer, nlayert + use clm_varctl , only : nhillslope + use clm_varcon , only : pondmx, watmin,rpi, secspday + use column_varcon , only : icol_road_perv + use abortutils , only : endrun + use GridcellType , only : grc + use landunit_varcon , only : istsoil, istcrop + use clm_varctl , only : use_hillslope_routing ! ! !ARGUMENTS: @@ -1906,47 +2111,46 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & integer , intent(in) :: filter_urbanc(:) ! column filter for urban points integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points type(soilstate_type) , intent(in) :: soilstate_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst type(soilhydrology_type) , intent(inout) :: soilhydrology_inst - type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst - type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(waterstatebulk_type), intent(inout) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + ! ! !LOCAL VARIABLES: - character(len=32) :: subname = 'Drainage' ! subroutine name - integer :: c,j,fc,i ! indices + character(len=32) :: subname = 'SubsurfaceLateralFlow' ! subroutine name + integer :: c,j,fc,i,l,g ! indices real(r8) :: dtime ! land model time step (sec) real(r8) :: xs(bounds%begc:bounds%endc) ! water needed to bring soil moisture to watmin (mm) real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevsoi) ! layer thickness (mm) integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) - real(r8) :: rsub_bot(bounds%begc:bounds%endc) ! subsurface runoff - bottom drainage (mm/s) - real(r8) :: rsub_top(bounds%begc:bounds%endc) ! subsurface runoff - topographic control (mm/s) + real(r8) :: drainage(bounds%begc:bounds%endc) ! subsurface drainage (mm/s) real(r8) :: xsi(bounds%begc:bounds%endc) ! excess soil water above saturation at layer i (mm) - real(r8) :: xsia(bounds%begc:bounds%endc) ! available pore space at layer i (mm) real(r8) :: xs1(bounds%begc:bounds%endc) ! excess soil water above saturation at layer 1 (mm) - real(r8) :: smpfz(1:nlevsoi) ! matric potential of layer right above water table (mm) - real(r8) :: wtsub ! summation of hk*dzmm for layers below water table (mm**2/s) real(r8) :: dzsum ! summation of dzmm of layers below water table (mm) real(r8) :: icefracsum ! summation of icefrac*dzmm of layers below water table (-) - real(r8) :: fracice_rsub(bounds%begc:bounds%endc) ! fractional impermeability of soil layers (-) + real(r8) :: ice_imped_col(bounds%begc:bounds%endc) ! column average hydraulic conductivity reduction due to presence of soil ice (-) + real(r8) :: ice_imped(bounds%begc:bounds%endc,1:nlevsoi) ! hydraulic conductivity reduction due to presence of soil ice (-) real(r8) :: available_h2osoi_liq ! available soil liquid water in a layer - real(r8) :: h2osoi_vol - real(r8) :: imped - real(r8) :: rsub_top_tot - real(r8) :: rsub_top_layer - real(r8) :: theta_unsat - real(r8) :: f_unsat - real(r8) :: s_y - integer :: k - real(r8) :: s1 - real(r8) :: s2 - real(r8) :: m - real(r8) :: b - real(r8) :: vol_ice - real(r8) :: dsmax_tmp(bounds%begc:bounds%endc) ! temporary variable for ARNO subsurface runoff calculation - real(r8) :: rsub_tmp ! temporary variable for ARNO subsurface runoff calculation - real(r8) :: frac ! temporary variable for ARNO subsurface runoff calculation - real(r8) :: rel_moist ! relative moisture, temporary variable - real(r8) :: wtsub_vic ! summation of hk*dzmm for layers in the third VIC layer - integer :: g + real(r8) :: h2osoi_vol ! volumetric water content (mm3/mm3) + real(r8) :: drainage_tot ! total drainage to be removed from column (mm) + real(r8) :: drainage_layer ! drainage to be removed from current layer (mm) + real(r8) :: s_y ! specific yield (unitless) + real(r8) :: vol_ice ! volumetric ice content (mm3/mm3) + logical, parameter :: no_lateral_flow = .false. ! flag for testing + real(r8) :: transmis ! transmissivity (m2/s) + real(r8) :: head_gradient ! hydraulic head gradient (m/m) + real(r8) :: stream_water_depth ! depth of water in stream channel (m) + real(r8) :: stream_channel_depth ! depth of stream channel (m) + real(r8) :: available_stream_water ! stream water (m3) + real(r8), parameter :: n_baseflow = 1 ! drainage power law exponent + real(r8), parameter :: k_anisotropic = 1._r8 ! anisotropy scalar + real(r8) :: qflx_latflow_out_vol(bounds%begc:bounds%endc) ! volumetric lateral flow (m3/s) + real(r8) :: qflx_net_latflow(bounds%begc:bounds%endc) ! net lateral flow in column (mm/s) + real(r8) :: qflx_latflow_avg(bounds%begc:bounds%endc) ! average lateral flow (mm/s) + real(r8) :: larea ! area of hillslope in landunit + integer :: c0, c_src, c_dst ! indices + !----------------------------------------------------------------------- associate( & @@ -1962,28 +2166,21 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) eff_porosity => soilstate_inst%eff_porosity_col , & ! Input: [real(r8) (:,:) ] effective porosity = porosity - vol_ice hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) + qflx_latflow_out => waterfluxbulk_inst%qflx_latflow_out_col, & ! Output: [real(r8) (:) ] lateral saturated outflow (mm/s) + qflx_latflow_in => waterfluxbulk_inst%qflx_latflow_in_col, & ! Output: [real(r8) (:) ] lateral saturated inflow (mm/s) + volumetric_discharge => waterfluxbulk_inst%volumetric_discharge_col , & ! Output: [real(r8) (:) ] discharge from column (m3/s) + + tdepth => wateratm2lndbulk_inst%tdepth_grc , & ! Input: [real(r8) (:) ] depth of water in tributary channels (m) + tdepth_bankfull => wateratm2lndbulk_inst%tdepthmax_grc , & ! Input: [real(r8) (:) ] bankfull depth of tributary channels (m) depth => soilhydrology_inst%depth_col , & ! Input: [real(r8) (:,:) ] VIC soil depth - c_param => soilhydrology_inst%c_param_col , & ! Input: [real(r8) (:) ] baseflow exponent (Qb) - Dsmax => soilhydrology_inst%dsmax_col , & ! Input: [real(r8) (:) ] max. velocity of baseflow (mm/day) - max_moist => soilhydrology_inst%max_moist_col , & ! Input: [real(r8) (:,:) ] maximum soil moisture (ice + liq) - moist => soilhydrology_inst%moist_col , & ! Input: [real(r8) (:,:) ] soil layer moisture (mm) - Ds => soilhydrology_inst%ds_col , & ! Input: [real(r8) (:) ] fracton of Dsmax where non-linear baseflow begins - Wsvic => soilhydrology_inst%Wsvic_col , & ! Input: [real(r8) (:) ] fraction of maximum soil moisutre where non-liear base flow occurs icefrac => soilhydrology_inst%icefrac_col , & ! Output: [real(r8) (:,:) ] fraction of ice in layer frost_table => soilhydrology_inst%frost_table_col , & ! Input: [real(r8) (:) ] frost table depth (m) zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) - wa => waterstatebulk_inst%wa_col , & ! Input: [real(r8) (:) ] water in the unconfined aquifer (mm) - ice => soilhydrology_inst%ice_col , & ! Input: [real(r8) (:,:) ] soil layer moisture (mm) - qcharge => soilhydrology_inst%qcharge_col , & ! Input: [real(r8) (:) ] aquifer recharge rate (mm/s) - origflag => soilhydrology_inst%origflag , & ! Input: logical - h2osfcflag => soilhydrology_inst%h2osfcflag , & ! Input: integer + stream_water_volume => waterstatebulk_inst%stream_water_volume_lun, & ! Input: [real(r8) (:) ] stream water volume (m3) qflx_snwcp_liq => waterfluxbulk_inst%qflx_snwcp_liq_col , & ! Output: [real(r8) (:) ] excess rainfall due to snow capping (mm H2O /s) [+] qflx_ice_runoff_xs => waterfluxbulk_inst%qflx_ice_runoff_xs_col , & ! Output: [real(r8) (:) ] solid runoff from excess ice in soil (mm H2O /s) [+] - qflx_liqdew_to_top_layer => waterfluxbulk_inst%qflx_liqdew_to_top_layer_col , & ! Output: [real(r8) (:) ] rate of liquid water deposited on top soil or snow layer (dew) (mm H2O /s) [+] - qflx_soliddew_to_top_layer => waterfluxbulk_inst%qflx_soliddew_to_top_layer_col , & ! Output: [real(r8) (:) ] rate of solid water deposited on top soil or snow layer (frost) (mm H2O /s) [+] - qflx_solidevap_from_top_layer => waterfluxbulk_inst%qflx_solidevap_from_top_layer_col, & ! Output: [real(r8) (:) ] rate of ice evaporated from top soil or snow layer (sublimation) (mm H2O /s) [+] qflx_drain => waterfluxbulk_inst%qflx_drain_col , & ! Output: [real(r8) (:) ] sub-surface runoff (mm H2O /s) qflx_qrgwl => waterfluxbulk_inst%qflx_qrgwl_col , & ! Output: [real(r8) (:) ] qflx_surf at glaciers, wetlands, lakes (mm H2O /s) qflx_rsub_sat => waterfluxbulk_inst%qflx_rsub_sat_col , & ! Output: [real(r8) (:) ] soil saturation excess [mm h2o/s] @@ -2003,7 +2200,8 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & dzmm(c,j) = dz(c,j)*1.e3_r8 vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) - icefrac(c,j) = min(1._r8,vol_ice/watsat(c,j)) + icefrac(c,j) = min(1._r8,vol_ice/watsat(c,j)) + ice_imped(c,j)=10._r8**(-params_inst%e_ice*icefrac(c,j)) end do end do @@ -2012,80 +2210,298 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) qflx_drain(c) = 0._r8 - rsub_bot(c) = 0._r8 qflx_rsub_sat(c) = 0._r8 - rsub_top(c) = 0._r8 - fracice_rsub(c) = 0._r8 - end do - - ! The layer index of the first unsaturated layer, - ! i.e., the layer right above the water table - - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - jwt(c) = nlevsoi - ! allow jwt to equal zero when zwt is in top layer - do j = 1,nlevsoi - if(zwt(c) <= zi(c,j)) then - jwt(c) = j-1 - exit - end if - enddo - end do - - !-- Topographic runoff ------------------------- - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - - dzsum = 0._r8 - icefracsum = 0._r8 - do j = max(jwt(c),1), nlevsoi - dzsum = dzsum + dzmm(c,j) - icefracsum = icefracsum + icefrac(c,j) * dzmm(c,j) - end do - imped=10._r8**(-params_inst%e_ice*(icefracsum/dzsum)) - !@@ - ! baseflow is power law expression relative to bedrock layer - if(zwt(c) <= zi(c,nbedrock(c))) then - rsub_top(c) = imped * baseflow_scalar * tan(rpi/180._r8*col%topo_slope(c))* & - (zi(c,nbedrock(c)) - zwt(c))**(params_inst%n_baseflow) - else - rsub_top(c) = 0._r8 - endif - - !-- Now remove water via rsub_top - rsub_top_tot = - rsub_top(c)* dtime - - !should never be positive... but include for completeness - if(rsub_top_tot > 0.) then !rising water table - - call endrun(subgrid_index=c, subgrid_level=subgrid_level_column, & - msg="RSUB_TOP IS POSITIVE in Drainage!"//errmsg(sourcefile, __LINE__)) - + drainage(c) = 0._r8 + qflx_latflow_in(c) = 0._r8 + qflx_latflow_out(c) = 0._r8 + qflx_net_latflow(c) = 0._r8 + volumetric_discharge(c) = 0._r8 + qflx_latflow_out_vol(c) = 0._r8 + end do + + ! The layer index of the first unsaturated layer, + ! i.e., the layer right above the water table + + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + jwt(c) = nlevsoi + ! allow jwt to equal zero when zwt is in top layer + do j = 1,nlevsoi + if(zwt(c) <= zi(c,j)) then + jwt(c) = j-1 + exit + end if + enddo + end do + + ! Calculate ice impedance factor (after jwt calculated) + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + dzsum = 0._r8 + icefracsum = 0._r8 + do j = max(jwt(c),1), nlevsoi + dzsum = dzsum + dzmm(c,j) + icefracsum = icefracsum + icefrac(c,j) * dzmm(c,j) + end do + ice_imped_col(c)=10._r8**(-params_inst%e_ice*(icefracsum/dzsum)) + enddo + + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + l = col%landunit(c) + g = col%gridcell(c) + ! Hillslope columns + if (col%is_hillslope_column(c) .and. col%active(c)) then + + ! method for calculating head gradient + if (head_gradient_method == kinematic) then + head_gradient = col%hill_slope(c) + else if (head_gradient_method == darcy) then + if (col%cold(c) /= ispval) then + head_gradient = (col%hill_elev(c)-zwt(c)) & + - (col%hill_elev(col%cold(c))-zwt(col%cold(c))) + head_gradient = head_gradient / (col%hill_distance(c) - col%hill_distance(col%cold(c))) + else + if (use_hillslope_routing) then + stream_water_depth = stream_water_volume(l) & + /lun%stream_channel_length(l)/lun%stream_channel_width(l) + stream_channel_depth = lun%stream_channel_depth(l) + else + stream_water_depth = tdepth(g) + stream_channel_depth = tdepth_bankfull(g) + endif + + ! flow between channel and lowest column + ! bankfull height is defined to be zero + head_gradient = (col%hill_elev(c)-zwt(c)) & + ! ignore overbankfull storage + - min((stream_water_depth - stream_channel_depth),0._r8) + + head_gradient = head_gradient / (col%hill_distance(c)) + ! head_gradient cannot be negative when channel is empty + if (stream_water_depth <= 0._r8) then + head_gradient = max(head_gradient, 0._r8) + endif + ! add vertical drainage for losing streams + ! (this could be a separate term from lateral flow...) + if (head_gradient < 0._r8) then + ! head_gradient = head_gradient - 1._r8 + ! adjust lateral gradient w/ k_anisotropic + head_gradient = head_gradient - 1._r8/k_anisotropic + endif + endif + else + call endrun(msg="head_gradient_method must be kinematic or darcy"//errmsg(sourcefile, __LINE__)) + end if + + !scs: in cases of bad data, where hand differences in + ! adjacent bins are very large, cap maximum head_gradient + ! should a warning be used instead? + head_gradient = min(max(head_gradient,-2._r8),2._r8) + + ! Determine source and destination columns + if (head_gradient >= 0._r8) then + c_src = c + c_dst = col%cold(c) + else + c_src = col%cold(c) + c_dst = c + endif + + ! Calculate transmissivity of source column + transmis = 0._r8 + if(c_src /= ispval) then + ! transmissivity non-zero only when saturated conditions exist + if(zwt(c_src) <= zi(c_src,nbedrock(c_src))) then + ! sum of layer transmissivities + if (transmissivity_method == layersum) then + do j = jwt(c_src)+1, nbedrock(c_src) + if(j == jwt(c_src)+1) then + transmis = transmis + 1.e-3_r8*ice_imped(c_src,j)*hksat(c_src,j)*(zi(c_src,j) - zwt(c_src)) + else + if(c_dst == ispval) then + ! lowland, gaining stream + ! only include layers above stream channel bottom + if ((col%hill_elev(c_src)-z(c_src,j)) > (-stream_channel_depth)) then + + transmis = transmis + 1.e-3_r8*ice_imped(c_src,j)*hksat(c_src,j)*dz(c_src,j) + endif + else + ! uplands + if ((col%hill_elev(c_src)-z(c_src,j)) > (col%hill_elev(c_dst) - zwt(c_dst))) then + transmis = transmis + 1.e-3_r8*ice_imped(c_src,j)*hksat(c_src,j)*dz(c_src,j) + endif + endif + endif + end do + ! constant conductivity based on shallowest saturated layer hk + else if (transmissivity_method == uniform_transmissivity) then + transmis = (1.e-3_r8*ice_imped(c_src,jwt(c_src)+1)*hksat(c_src,jwt(c_src)+1)) & + *(zi(c_src,nbedrock(c_src)) - zwt(c_src) ) + else + call endrun(msg="transmissivity_method must be LayerSum or Uniform"//errmsg(sourcefile, __LINE__)) + endif + endif + else + ! transmissivity of losing stream (c_src == ispval) + transmis = (1.e-3_r8*ice_imped(c,jwt(c)+1)*hksat(c,jwt(c)+1))*stream_water_depth + endif + ! adjust transmissivity by 'anisotropy factor' + transmis = k_anisotropic*transmis + + ! the qflx_latflow_out_vol calculations use the + ! transmissivity to determine whether saturated flow + ! conditions exist, b/c gradients will be nonzero + ! even when no saturated layers are present + ! qflx_latflow_out_vol(c) = ice_imped(c)*transmis*col%hill_width(c)*head_gradient + ! include ice impedance in transmissivity + qflx_latflow_out_vol(c) = transmis*col%hill_width(c)*head_gradient + + ! When head gradient is negative (losing stream channel), + ! limit outflow by available stream channel water + if (use_hillslope_routing .and. (qflx_latflow_out_vol(c) < 0._r8)) then + available_stream_water = stream_water_volume(l)/lun%stream_channel_number(l)/nhillslope + if(abs(qflx_latflow_out_vol(c))*dtime > available_stream_water) then + qflx_latflow_out_vol(c) = -available_stream_water/dtime + endif + endif + + ! volumetric_discharge from lowest column is qflx_latflow_out_vol + ! scaled by total area of column in gridcell divided by column area + if (col%cold(c) == ispval) then + volumetric_discharge(c) = qflx_latflow_out_vol(c) & + *(grc%area(g)*1.e6_r8*col%wtgcell(c)/col%hill_area(c)) + endif + + ! convert volumetric flow to equivalent flux + qflx_latflow_out(c) = 1.e3_r8*qflx_latflow_out_vol(c)/col%hill_area(c) + + ! hilltop column has no inflow + if (col%colu(c) == ispval) then + qflx_latflow_in(c) = 0._r8 + endif + + ! current outflow is inflow to downhill column normalized by downhill area + if (col%cold(c) /= ispval) then + qflx_latflow_in(col%cold(c)) = qflx_latflow_in(col%cold(c)) + & + 1.e3_r8*qflx_latflow_out_vol(c)/col%hill_area(col%cold(c)) + endif + + else + ! Non-hillslope columns + ! baseflow is power law expression relative to bedrock layer + if(zwt(c) <= zi(c,nbedrock(c))) then + qflx_latflow_out(c) = ice_imped_col(c) * baseflow_scalar & + * tan(rpi/180._r8*col%topo_slope(c))* & + (zi(c,nbedrock(c)) - zwt(c))**(params_inst%n_baseflow) + endif + ! convert flux to volumetric flow + qflx_latflow_out_vol(c) = 1.e-3_r8*qflx_latflow_out(c)*(grc%area(g)*1.e6_r8*col%wtgcell(c)) + volumetric_discharge(c) = qflx_latflow_out_vol(c) + endif + enddo + + ! recalculate average flux for no-lateral flow case + if(no_lateral_flow) then + if (head_gradient_method /= kinematic) then + call endrun(msg="head_gradient_method must be kinematic for no_lateral_flow = .true.! "//errmsg(sourcefile, __LINE__)) + endif + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + if (col%is_hillslope_column(c) .and. col%active(c)) then + l = col%landunit(c) + !need to sum all columns w/ same hillslope id for each column + qflx_latflow_avg(c) = 0._r8 + larea = 0._r8 + do c0 = lun%coli(l), lun%colf(l) + if(col%hillslope_ndx(c0) == col%hillslope_ndx(c)) then + qflx_latflow_avg(c) = qflx_latflow_avg(c) + qflx_latflow_out_vol(c0) + larea = larea + col%hill_area(c0) + endif + enddo + qflx_latflow_avg(c) = 1.e3_r8*qflx_latflow_avg(c)/larea + else + qflx_latflow_avg(c) = qflx_latflow_out(c) + endif + enddo + endif + + !-- Topographic runoff ------------------------- + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + + ! net lateral flow (positive out) + qflx_net_latflow(c) = qflx_latflow_out(c) - qflx_latflow_in(c) + if(no_lateral_flow) then + qflx_net_latflow(c) = qflx_latflow_avg(c) + endif + + !@@ + ! baseflow + if(zwt(c) <= zi(c,nbedrock(c))) then + ! apply net lateral flow here + drainage(c) = qflx_net_latflow(c) + else + drainage(c) = 0._r8 + endif + + !-- Now remove water via drainage + drainage_tot = - drainage(c) * dtime + + if(drainage_tot > 0.) then !rising water table + do j = jwt(c)+1,1,-1 + + ! ensure water is not added to frozen layers + if (zi(c,j) < frost_table(c)) then + ! analytical expression for specific yield + s_y = watsat(c,j) & + * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) + s_y=max(s_y,params_inst%aq_sp_yield_min) + + drainage_layer=min(drainage_tot,(s_y*dz(c,j)*1.e3)) + + drainage_layer=max(drainage_layer,0._r8) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + drainage_layer + + drainage_tot = drainage_tot - drainage_layer + + if (drainage_tot <= 0.) then + zwt(c) = zwt(c) - drainage_layer/s_y/1000._r8 + exit + else + zwt(c) = zi(c,j-1) + endif + endif + + enddo + + !-- remove residual drainage -------------------------------- + h2osfc(c) = h2osfc(c) + drainage_tot + else ! deepening water table do j = jwt(c)+1, nbedrock(c) - ! use analytical expression for specific yield + ! analytical expression for specific yield s_y = watsat(c,j) & * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) - s_y=max(s_y, params_inst%aq_sp_yield_min) - rsub_top_layer=max(rsub_top_tot,-(s_y*(zi(c,j) - zwt(c))*1.e3)) - rsub_top_layer=min(rsub_top_layer,0._r8) - h2osoi_liq(c,j) = h2osoi_liq(c,j) + rsub_top_layer - - rsub_top_tot = rsub_top_tot - rsub_top_layer + s_y=max(s_y,params_inst%aq_sp_yield_min) + + drainage_layer=max(drainage_tot,-(s_y*(zi(c,j) - zwt(c))*1.e3)) + drainage_layer=min(drainage_layer,0._r8) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + drainage_layer - if (rsub_top_tot >= 0.) then - zwt(c) = zwt(c) - rsub_top_layer/s_y/1000._r8 + drainage_tot = drainage_tot - drainage_layer + if (drainage_tot >= 0.) then + zwt(c) = zwt(c) - drainage_layer/s_y/1000._r8 exit else zwt(c) = zi(c,j) endif enddo - !-- remove residual rsub_top -------------------------------- + !-- remove residual drainage ----------------------- ! make sure no extra water removed from soil column - rsub_top(c) = rsub_top(c) + rsub_top_tot/dtime + drainage(c) = drainage(c) + drainage_tot/dtime endif zwt(c) = max(0.0_r8,zwt(c)) @@ -2100,7 +2516,7 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & c = filter_hydrologyc(fc) xsi(c) = max(h2osoi_liq(c,j)-eff_porosity(c,j)*dzmm(c,j),0._r8) h2osoi_liq(c,j) = min(eff_porosity(c,j)*dzmm(c,j), h2osoi_liq(c,j)) - h2osoi_liq(c,j-1) = h2osoi_liq(c,j-1) + xsi(c) + h2osoi_liq(c,j-1) = h2osoi_liq(c,j-1) + xsi(c) end do end do @@ -2173,16 +2589,16 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & ! Instead of removing water from aquifer where it eventually ! shows up as excess drainage to the ocean, take it back out of ! drainage - qflx_rsub_sat(c) = qflx_rsub_sat(c) - xs(c)/dtime + qflx_rsub_sat(c) = qflx_rsub_sat(c) - xs(c)/dtime end do + do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) ! Sub-surface runoff and drainage - - qflx_drain(c) = qflx_rsub_sat(c) + rsub_top(c) + qflx_drain(c) = qflx_rsub_sat(c) + drainage(c) ! Set imbalance for snow capping @@ -2190,6 +2606,7 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & end do + ! No drainage for urban columns (except for pervious road as computed above) do fc = 1, num_urbanc @@ -2203,7 +2620,7 @@ subroutine LateralFlowPowerLaw(bounds, num_hydrologyc, filter_hydrologyc, & end associate - end subroutine LateralFlowPowerLaw + end subroutine SubsurfaceLateralFlow !#7 !----------------------------------------------------------------------- diff --git a/src/biogeophys/SoilHydrologyType.F90 b/src/biogeophys/SoilHydrologyType.F90 index 4dfca06811..07ad2ca45b 100644 --- a/src/biogeophys/SoilHydrologyType.F90 +++ b/src/biogeophys/SoilHydrologyType.F90 @@ -19,8 +19,6 @@ Module SoilHydrologyType type, public :: soilhydrology_type integer :: h2osfcflag ! true => surface water is active (namelist) - integer :: origflag ! used to control soil hydrology properties (namelist) - real(r8), pointer :: num_substeps_col (:) ! col adaptive timestep counter ! NON-VIC real(r8), pointer :: frost_table_col (:) ! col frost table depth @@ -28,7 +26,6 @@ Module SoilHydrologyType real(r8), pointer :: zwts_col (:) ! col water table depth, the shallower of the two water depths real(r8), pointer :: zwt_perched_col (:) ! col perched water table depth real(r8), pointer :: qcharge_col (:) ! col aquifer recharge rate (mm/s) - real(r8), pointer :: fracice_col (:,:) ! col fractional impermeability (-) real(r8), pointer :: icefrac_col (:,:) ! col fraction of ice real(r8), pointer :: h2osfc_thresh_col (:) ! col level at which h2osfc "percolates" (time constant) real(r8), pointer :: xs_urban_col (:) ! col excess soil water above urban ponding limit @@ -121,7 +118,6 @@ subroutine InitAllocate(this, bounds) allocate(this%zwts_col (begc:endc)) ; this%zwts_col (:) = nan allocate(this%qcharge_col (begc:endc)) ; this%qcharge_col (:) = nan - allocate(this%fracice_col (begc:endc,nlevgrnd)) ; this%fracice_col (:,:) = nan allocate(this%icefrac_col (begc:endc,nlevgrnd)) ; this%icefrac_col (:,:) = nan allocate(this%h2osfc_thresh_col (begc:endc)) ; this%h2osfc_thresh_col (:) = nan allocate(this%xs_urban_col (begc:endc)) ; this%xs_urban_col (:) = nan @@ -340,16 +336,14 @@ subroutine ReadNL( this, NLFilename ) ! !LOCAL VARIABLES: integer :: ierr ! error code integer :: unitn ! unit for namelist file - integer :: origflag=0 !use to control soil hydraulic properties integer :: h2osfcflag=1 !If surface water is active or not character(len=32) :: subname = 'SoilHydrology_readnl' ! subroutine name !----------------------------------------------------------------------- - namelist / clm_soilhydrology_inparm / h2osfcflag, origflag + namelist / clm_soilhydrology_inparm / h2osfcflag ! preset values - origflag = 0 h2osfcflag = 1 if ( masterproc )then @@ -371,10 +365,8 @@ subroutine ReadNL( this, NLFilename ) end if call shr_mpi_bcast(h2osfcflag, mpicom) - call shr_mpi_bcast(origflag, mpicom) this%h2osfcflag = h2osfcflag - this%origflag = origflag end subroutine ReadNL diff --git a/src/biogeophys/SoilWaterMovementMod.F90 b/src/biogeophys/SoilWaterMovementMod.F90 index b1487e2779..85bcf42c5e 100644 --- a/src/biogeophys/SoilWaterMovementMod.F90 +++ b/src/biogeophys/SoilWaterMovementMod.F90 @@ -575,10 +575,8 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) - origflag => soilhydrology_inst%origflag , & ! Input: constant qcharge => soilhydrology_inst%qcharge_col , & ! Input: [real(r8) (:) ] aquifer recharge rate (mm/s) zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) - fracice => soilhydrology_inst%fracice_col , & ! Input: [real(r8) (:,:) ] fractional impermeability (-) icefrac => soilhydrology_inst%icefrac_col , & ! Input: [real(r8) (:,:) ] fraction of ice hkdepth => soilhydrology_inst%hkdepth_col , & ! Input: [real(r8) (:) ] decay factor (m) @@ -720,22 +718,13 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & c = filter_hydrologyc(fc) ! compute hydraulic conductivity based on liquid water content only - if (origflag == 1) then - s1 = 0.5_r8*(h2osoi_vol(c,j) + h2osoi_vol(c,min(nlevsoi, j+1))) / & - (0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) - else - s1 = 0.5_r8*(vwc_liq(c,j) + vwc_liq(c,min(nlevsoi, j+1))) / & - (0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) - endif + s1 = 0.5_r8*(vwc_liq(c,j) + vwc_liq(c,min(nlevsoi, j+1))) / & + (0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) s1 = min(1._r8, s1) s2 = hksat(c,j)*s1**(2._r8*bsw(c,j)+2._r8) - ! replace fracice with impedance factor, as in zhao 97,99 - if (origflag == 1) then - imped(c,j)=(1._r8-0.5_r8*(fracice(c,j)+fracice(c,min(nlevsoi, j+1)))) - else - imped(c,j)=10._r8**(-params_inst%e_ice*(0.5_r8*(icefrac(c,j)+icefrac(c,min(nlevsoi, j+1))))) - endif + imped(c,j)=10._r8**(-params_inst%e_ice*(0.5_r8*(icefrac(c,j)+icefrac(c,min(nlevsoi, j+1))))) + hk(c,j) = imped(c,j)*s1*s2 dhkdw(c,j) = imped(c,j)*(2._r8*bsw(c,j)+3._r8)*s2* & (1._r8/(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) @@ -751,11 +740,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! compute matric potential and derivative based on liquid water content only - if (origflag == 1) then - s_node = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) - else - s_node = max(vwc_liq(c,j)/watsat(c,j), 0.01_r8) - endif + s_node = max(vwc_liq(c,j)/watsat(c,j), 0.01_r8) s_node = min(1.0_r8, s_node) !call soil_water_retention_curve%soil_suction(sucsat(c,j), s_node, bsw(c,j), smp(c,j), dsmpds) @@ -765,11 +750,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & !do not turn on the line below, which will cause bit to bit error, jyt, 2014 Mar 6 !dsmpdw(c,j) = dsmpds/watsat(c,j) - if (origflag == 1) then - dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/(s_node*watsat(c,j)) - else - dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/vwc_liq(c,j) - endif + dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/vwc_liq(c,j) smp_l(c,j) = smp(c,j) hk_l(c,j) = hk(c,j) @@ -861,11 +842,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & else ! water table is below soil column ! compute aquifer soil moisture as average of layer 10 and saturation - if(origflag == 1) then - s_node = max(0.5*(1.0_r8+h2osoi_vol(c,j)/watsat(c,j)), 0.01_r8) - else - s_node = max(0.5*((vwc_zwt(c)+vwc_liq(c,j))/watsat(c,j)), 0.01_r8) - endif + s_node = max(0.5*((vwc_zwt(c)+vwc_liq(c,j))/watsat(c,j)), 0.01_r8) s_node = min(1.0_r8, s_node) ! compute smp for aquifer layer @@ -940,7 +917,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & s_node = max(h2osoi_vol(c,jwt(c)+1)/watsat(c,jwt(c)+1), 0.01_r8) s1 = min(1._r8, s_node) - !scs: this is the expression for unsaturated hk + !this is the expression for unsaturated hk ka = imped(c,jwt(c)+1)*hksat(c,jwt(c)+1) & *s1**(2._r8*bsw(c,jwt(c)+1)+3._r8) @@ -953,12 +930,12 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & smp1 = max(smpmin(c), smp(c,max(1,jwt(c)))) wh = smp1 - zq(c,max(1,jwt(c))) - !scs: original formulation + !original formulation if(jwt(c) == 0) then qcharge(c) = -ka * (wh_zwt-wh) /((zwt(c)+1.e-3)*1000._r8) else ! qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8) - !scs: 1/2, assuming flux is at zwt interface, saturation deeper than zwt + !1/2, assuming flux is at zwt interface, saturation deeper than zwt qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8*2.0) endif @@ -1164,6 +1141,7 @@ subroutine soilwater_moisture_form(bounds, num_hydrologyc, & real(r8) :: vLiqRes(bounds%begc:bounds%endc,1:nlevsoi) ! residual for the volumetric liquid water content (v/v) real(r8) :: dwat_temp + real(r8) :: over_saturation !----------------------------------------------------------------------- associate(& @@ -1177,6 +1155,7 @@ subroutine soilwater_moisture_form(bounds, num_hydrologyc, & qcharge => soilhydrology_inst%qcharge_col , & ! Input: [real(r8) (:) ] aquifer recharge rate (mm/s) zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) smp_l => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) h2osoi_ice => waterstatebulk_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice water (kg/m2) @@ -1413,10 +1392,10 @@ subroutine soilwater_moisture_form(bounds, num_hydrologyc, & end do ! substep loop -! save number of adaptive substeps used during time step + ! save number of adaptive substeps used during time step nsubsteps(c) = nsubstep -! check for negative moisture values + ! check for negative moisture values do j = 2, nlayers if(h2osoi_liq(c,j) < -1e-6_r8) then write(*,*) 'layer, h2osoi_liq: ', c,j,h2osoi_liq(c,j) @@ -1494,7 +1473,7 @@ subroutine compute_hydraulic_properties(c, nlayers, & character(len=32) :: subname = 'calculate_hydraulic_properties' ! subroutine name !----------------------------------------------------------------------- -!scs: originally, associate statements selected sections rather than +! originally, associate statements selected sections rather than ! entire arrays, but due to pgi bug, removed array section selections ! using array sections allowed consistent 1d indexing throughout associate(& @@ -1621,7 +1600,7 @@ subroutine compute_moisture_fluxes_and_derivs(c, nlayers, & real(r8) :: num, den ! used in calculating qin, qout real(r8) :: dhkds1, dhkds2 !temporary variable real(r8),parameter :: m_to_mm = 1.e3_r8 !convert meters to mm -!scs: temporarily use local variables for the following + ! temporarily use local variables for the following real(r8) :: vwc_liq_ub ! liquid volumetric water content at upper boundary real(r8) :: vwc_liq_lb ! liquid volumetric water content at lower boundary character(len=32) :: subname = 'calculate_moisture_fluxes_and_derivs' ! subroutine name @@ -1704,12 +1683,11 @@ subroutine compute_moisture_fluxes_and_derivs(c, nlayers, & dhkds1 = 0.5_r8 * dhkdw(j) / watsat(c,j) ! derivative w.r.t. volumetric liquid water in the upper layer dhkds2 = 0.5_r8 * dhkdw(j) / watsat(c,j+1) ! derivative w.r.t. volumetric liquid water in the lower layer -!scs: this is how zd is done + ! this is how zd is done if (zdflag == 1) then dhkds1 = dhkdw(j)/(watsat(c,j)+watsat(c,min(nlevsoi, j+1))) dhkds2 = dhkds1 endif -!scs ! compute flux at the bottom of the j-th layer ! NOTE: hk(j) is hydraulic conductivity at the bottom of the j-th @@ -1739,12 +1717,11 @@ subroutine compute_moisture_fluxes_and_derivs(c, nlayers, & ! layer interface w.r.t relative saturation at the interface dhkds1 = 0.5_r8 * dhkdw(j) / watsat(c,j) ! derivative w.r.t. volumetric liquid water in the upper layer dhkds2 = 0.5_r8 * dhkdw(j) / watsat(c,j+1) ! derivative w.r.t. volumetric liquid water in the lower layer -!scs: this is how zd is done + ! this is how zd is done if (zdflag == 1) then dhkds1 = dhkdw(j)/(watsat(c,j)+watsat(c,min(nlevsoi, j+1))) dhkds2 = dhkds1 endif -!scs ! compute flux at the bottom of the j-th layer ! NOTE: hk(j) is hydraulic conductivity at the bottom of the j-th layer @@ -1801,12 +1778,12 @@ subroutine compute_moisture_fluxes_and_derivs(c, nlayers, & ! condition when the water table is a long way below the soil column dhkds1 = dhkdw(j) / watsat(c,j) -!scs: this is how zd is done + ! this is how zd is done if (zdflag == 1) then dhkds1 = dhkdw(j)/(watsat(c,j)+watsat(c,min(nlevsoi, j+1))) dhkds2 = dhkds1 endif -!scs + ! compute flux num = -smp(j) ! NOTE: assume saturation at water table depth (smp=0) den = m_to_mm * (zwt(c) - z(c,j)) @@ -1824,7 +1801,7 @@ subroutine compute_moisture_fluxes_and_derivs(c, nlayers, & ! compute the relative saturation at the lower boundary s1 = vwc_liq_lb / watsat(c,j) -!scs: mc's original expression s1 = (vwc_liq_lb - watres(c,j)) / (watsat(c,j) - watres(c,j)) + ! mc's original expression s1 = (vwc_liq_lb - watres(c,j)) / (watsat(c,j) - watres(c,j)) s1 = min(s1, 1._r8) s1 = max(0.01_r8, s1) diff --git a/src/biogeophys/SurfaceAlbedoMod.F90 b/src/biogeophys/SurfaceAlbedoMod.F90 index d23320d5e7..6628f0fa4d 100644 --- a/src/biogeophys/SurfaceAlbedoMod.F90 +++ b/src/biogeophys/SurfaceAlbedoMod.F90 @@ -261,6 +261,8 @@ subroutine SurfaceAlbedo(bounds,nc, & use abortutils , only : endrun use clm_varctl , only : use_subgrid_fluxes, use_snicar_frc, use_fates use CLMFatesInterfaceMod, only : hlm_fates_interface_type + use landunit_varcon , only : istsoil + use clm_varctl , only : downscale_hillslope_meteorology ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds @@ -305,7 +307,6 @@ subroutine SurfaceAlbedo(bounds,nc, & real(r8) :: ws (bounds%begp:bounds%endp) ! fraction of LAI+SAI that is SAI real(r8) :: blai(bounds%begp:bounds%endp) ! lai buried by snow: tlai - elai real(r8) :: bsai(bounds%begp:bounds%endp) ! sai buried by snow: tsai - esai - real(r8) :: coszen_gcell (bounds%begg:bounds%endg) ! cosine solar zenith angle for next time step (grc) real(r8) :: coszen_patch (bounds%begp:bounds%endp) ! cosine solar zenith angle for next time step (patch) real(r8) :: rho(bounds%begp:bounds%endp,numrad) ! leaf/stem refl weighted by fraction LAI and SAI real(r8) :: tau(bounds%begp:bounds%endp,numrad) ! leaf/stem tran weighted by fraction LAI and SAI @@ -334,6 +335,7 @@ subroutine SurfaceAlbedo(bounds,nc, & real(r8) :: mss_cnc_aer_in_fdb (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero integer , parameter :: nband =numrad ! number of solar radiation waveband classes + real(r8) :: zenith_angle !----------------------------------------------------------------------- associate(& @@ -369,6 +371,8 @@ subroutine SurfaceAlbedo(bounds,nc, & vcmaxcintsha => surfalb_inst%vcmaxcintsha_patch , & ! Output: [real(r8) (:) ] leaf to canopy scaling coefficient, shaded leaf vcmax ncan => surfalb_inst%ncan_patch , & ! Output: [integer (:) ] number of canopy layers nrad => surfalb_inst%nrad_patch , & ! Output: [integer (:) ] number of canopy layers, above snow for radiative transfer + azsun_grc => surfalb_inst%azsun_grc , & ! Output: [real(r8) (:) ] cosine of solar zenith angle + coszen_grc => surfalb_inst%coszen_grc , & ! Output: [real(r8) (:) ] cosine of solar zenith angle coszen_col => surfalb_inst%coszen_col , & ! Output: [real(r8) (:) ] cosine of solar zenith angle albgrd => surfalb_inst%albgrd_col , & ! Output: [real(r8) (:,:) ] ground albedo (direct) albgri => surfalb_inst%albgri_col , & ! Output: [real(r8) (:,:) ] ground albedo (diffuse) @@ -426,16 +430,29 @@ subroutine SurfaceAlbedo(bounds,nc, & ! Cosine solar zenith angle for next time step do g = bounds%begg,bounds%endg - coszen_gcell(g) = shr_orb_cosz (nextsw_cday, grc%lat(g), grc%lon(g), declinp1) + coszen_grc(g) = shr_orb_cosz (nextsw_cday, grc%lat(g), grc%lon(g), declinp1) end do + do c = bounds%begc,bounds%endc g = col%gridcell(c) - coszen_col(c) = coszen_gcell(g) + if (col%is_hillslope_column(c) .and. downscale_hillslope_meteorology) then + ! calculate local incidence angle based on column slope and aspect + zenith_angle = acos(coszen_grc(g)) + + azsun_grc(g) = shr_orb_azimuth(nextsw_cday, grc%lat(g), grc%lon(g), declinp1, zenith_angle) + ! hill_slope is [m/m], convert to radians + coszen_col(c) = shr_orb_cosinc(zenith_angle,azsun_grc(g),atan(col%hill_slope(c)),col%hill_aspect(c)) + + if(coszen_grc(g) > 0._r8 .and. coszen_col(c) < 0._r8) coszen_col(c) = 0._r8 + + else + coszen_col(c) = coszen_grc(g) + endif end do do fp = 1,num_nourbanp p = filter_nourbanp(fp) - g = patch%gridcell(p) - coszen_patch(p) = coszen_gcell(g) + c = patch%column(p) + coszen_patch(p) = coszen_col(c) end do ! Initialize output because solar radiation only done if coszen > 0 diff --git a/src/biogeophys/SurfaceAlbedoType.F90 b/src/biogeophys/SurfaceAlbedoType.F90 index a8b645b84a..ddb57d88f7 100644 --- a/src/biogeophys/SurfaceAlbedoType.F90 +++ b/src/biogeophys/SurfaceAlbedoType.F90 @@ -16,6 +16,8 @@ module SurfaceAlbedoType ! !PUBLIC DATA MEMBERS: type, public :: surfalb_type + real(r8), pointer :: azsun_grc (:) ! azimuth angle of sun + real(r8), pointer :: coszen_grc (:) ! gridcell cosine of solar zenith angle real(r8), pointer :: coszen_col (:) ! col cosine of solar zenith angle real(r8), pointer :: albd_patch (:,:) ! patch surface albedo (direct) (numrad) real(r8), pointer :: albi_patch (:,:) ! patch surface albedo (diffuse) (numrad) @@ -123,11 +125,15 @@ subroutine InitAllocate(this, bounds) ! !LOCAL VARIABLES: integer :: begp, endp integer :: begc, endc + integer :: begg, endg !--------------------------------------------------------------------- begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + allocate(this%azsun_grc (begg:endg)) ; this%azsun_grc (:) = nan + allocate(this%coszen_grc (begg:endg)) ; this%coszen_grc (:) = nan allocate(this%coszen_col (begc:endc)) ; this%coszen_col (:) = nan allocate(this%albgrd_col (begc:endc,numrad)) ; this%albgrd_col (:,:) = nan allocate(this%albgri_col (begc:endc,numrad)) ; this%albgri_col (:,:) = nan @@ -210,15 +216,27 @@ subroutine InitHistory(this, bounds) ! !LOCAL VARIABLES: integer :: begp, endp integer :: begc, endc + integer :: begg, endg character(len=cs) :: defaultoutput !--------------------------------------------------------------------- begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + this%azsun_grc(begg:endg) = spval + call hist_addfld1d (fname='AZSUN', units='radians', & + avgflag='A', long_name='cosine of solar zenith angle', & + ptr_lnd=this%azsun_grc, default='inactive') + + this%coszen_grc(begg:endg) = spval + call hist_addfld1d (fname='COSZEN_GRC', units='none', & + avgflag='A', long_name='cosine of solar zenith angle', & + ptr_lnd=this%coszen_grc, default='inactive') this%coszen_col(begc:endc) = spval call hist_addfld1d (fname='COSZEN', units='none', & - avgflag='A', long_name='cosine of solar zenith angle', & + avgflag='A', long_name='cosine of solar zenith angle (downscaled if downscaling is activated)', & ptr_col=this%coszen_col, default='inactive') this%albgrd_col(begc:endc,:) = spval @@ -418,6 +436,11 @@ subroutine Restart(this, bounds, ncid, flag, & begp = bounds%begp; endp = bounds%endp begc = bounds%begc; endc = bounds%endc + call restartvar(ncid=ncid, flag=flag, varname='coszen_grc', xtype=ncd_double, & + dim1name='gridcell', & + long_name='cosine of solar zenith angle', units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%coszen_grc) + call restartvar(ncid=ncid, flag=flag, varname='coszen', xtype=ncd_double, & dim1name='column', & long_name='cosine of solar zenith angle', units='unitless', & diff --git a/src/biogeophys/SurfaceRadiationMod.F90 b/src/biogeophys/SurfaceRadiationMod.F90 index 03557c6476..5de3ba6e09 100644 --- a/src/biogeophys/SurfaceRadiationMod.F90 +++ b/src/biogeophys/SurfaceRadiationMod.F90 @@ -383,6 +383,7 @@ subroutine CanopySunShadeFracs(filter_nourbanp, num_nourbanp, & ! local variables integer :: fp ! non-urban filter patch index integer :: p ! patch index + integer :: c ! column index integer :: g ! gridcell index integer :: iv ! canopy layer index integer,parameter :: ipar = 1 ! The band index for PAR @@ -390,7 +391,7 @@ subroutine CanopySunShadeFracs(filter_nourbanp, num_nourbanp, & associate( tlai_z => surfalb_inst%tlai_z_patch, & ! tlai increment for canopy layer fsun_z => surfalb_inst%fsun_z_patch, & ! sunlit fraction of canopy layer elai => canopystate_inst%elai_patch, & ! one-sided leaf area index - forc_solad => atm2lnd_inst%forc_solad_grc, & ! direct beam radiation (W/m**2) + forc_solad_col => atm2lnd_inst%forc_solad_downscaled_col, & ! direct beam radiation, column (W/m**2) forc_solai => atm2lnd_inst%forc_solai_grc, & ! diffuse radiation (W/m**2) fabd_sun_z => surfalb_inst%fabd_sun_z_patch, & ! absorbed sunlit leaf direct PAR fabd_sha_z => surfalb_inst%fabd_sha_z_patch, & ! absorbed shaded leaf direct PAR @@ -440,10 +441,11 @@ subroutine CanopySunShadeFracs(filter_nourbanp, num_nourbanp, & ! are canopy integrated so that layer values equal big leaf values. g = patch%gridcell(p) + c = patch%column(p) do iv = 1, nrad(p) - parsun_z(p,iv) = forc_solad(g,ipar)*fabd_sun_z(p,iv) + forc_solai(g,ipar)*fabi_sun_z(p,iv) - parsha_z(p,iv) = forc_solad(g,ipar)*fabd_sha_z(p,iv) + forc_solai(g,ipar)*fabi_sha_z(p,iv) + parsun_z(p,iv) = forc_solad_col(c,ipar)*fabd_sun_z(p,iv) + forc_solai(g,ipar)*fabi_sun_z(p,iv) + parsha_z(p,iv) = forc_solad_col(c,ipar)*fabd_sha_z(p,iv) + forc_solai(g,ipar)*fabi_sha_z(p,iv) end do end do ! end of fp = 1,num_nourbanp loop @@ -533,7 +535,7 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & associate( & snl => col%snl , & ! Input: [integer (:) ] negative number of snow layers [nbr] - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (W/m**2) + forc_solad_col => atm2lnd_inst%forc_solad_downscaled_col , & ! Input: [real(r8) (:,:) ] direct beam radiation, column (W/m**2) forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (W/m**2) snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) @@ -682,7 +684,7 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! Absorbed by canopy - cad(p,ib) = forc_solad(g,ib)*fabd(p,ib) + cad(p,ib) = forc_solad_col(c,ib)*fabd(p,ib) cai(p,ib) = forc_solai(g,ib)*fabi(p,ib) sabv(p) = sabv(p) + cad(p,ib) + cai(p,ib) fsa(p) = fsa(p) + cad(p,ib) + cai(p,ib) @@ -695,8 +697,8 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! Transmitted = solar fluxes incident on ground - trd(p,ib) = forc_solad(g,ib)*ftdd(p,ib) - tri(p,ib) = forc_solad(g,ib)*ftid(p,ib) + forc_solai(g,ib)*ftii(p,ib) + trd(p,ib) = forc_solad_col(c,ib)*ftdd(p,ib) + tri(p,ib) = forc_solad_col(c,ib)*ftid(p,ib) + forc_solai(g,ib)*ftii(p,ib) ! Solar radiation absorbed by ground surface ! calculate absorbed solar by soil/snow separately absrad = trd(p,ib)*(1._r8-albsod(c,ib)) + tri(p,ib)*(1._r8-albsoi(c,ib)) @@ -887,29 +889,30 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & do fp = 1,num_nourbanp p = filter_nourbanp(fp) g = patch%gridcell(p) + c = patch%column(p) ! NDVI and reflected solar radiation - rvis = albd(p,1)*forc_solad(g,1) + albi(p,1)*forc_solai(g,1) - rnir = albd(p,2)*forc_solad(g,2) + albi(p,2)*forc_solai(g,2) + rvis = albd(p,1)*forc_solad_col(c,1) + albi(p,1)*forc_solai(g,1) + rnir = albd(p,2)*forc_solad_col(c,2) + albi(p,2)*forc_solai(g,2) fsr(p) = rvis + rnir if (use_SSRE) then - rvisSF = albdSF(p,1)*forc_solad(g,1) + albiSF(p,1)*forc_solai(g,1) - rnirSF = albdSF(p,2)*forc_solad(g,2) + albiSF(p,2)*forc_solai(g,2) + rvisSF = albdSF(p,1)*forc_solad_col(c,1) + albiSF(p,1)*forc_solai(g,1) + rnirSF = albdSF(p,2)*forc_solad_col(c,2) + albiSF(p,2)*forc_solai(g,2) fsrSF(p) = rvisSF + rnirSF ssre_fsr(p) = fsr(p)-fsrSF(p) end if - fsds_vis_d(p) = forc_solad(g,1) - fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_d(p) = forc_solad_col(c,1) + fsds_nir_d(p) = forc_solad_col(c,2) fsds_vis_i(p) = forc_solai(g,1) fsds_nir_i(p) = forc_solai(g,2) - fsr_vis_d(p) = albd(p,1)*forc_solad(g,1) - fsr_nir_d(p) = albd(p,2)*forc_solad(g,2) + fsr_vis_d(p) = albd(p,1)*forc_solad_col(c,1) + fsr_nir_d(p) = albd(p,2)*forc_solad_col(c,2) fsr_vis_i(p) = albi(p,1)*forc_solai(g,1) fsr_nir_i(p) = albi(p,2)*forc_solai(g,2) if (use_SSRE) then - fsrSF_vis_d(p) = albdSF(p,1)*forc_solad(g,1) - fsrSF_nir_d(p) = albdSF(p,2)*forc_solad(g,2) + fsrSF_vis_d(p) = albdSF(p,1)*forc_solad_col(c,1) + fsrSF_nir_d(p) = albdSF(p,2)*forc_solad_col(c,2) fsrSF_vis_i(p) = albiSF(p,1)*forc_solai(g,1) fsrSF_nir_i(p) = albiSF(p,2)*forc_solai(g,2) @@ -919,10 +922,10 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ssre_fsr_nir_i(p) = fsrSF_nir_i(p)-fsr_nir_i(p) end if if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then - fsds_vis_d_ln(p) = forc_solad(g,1) - fsds_nir_d_ln(p) = forc_solad(g,2) - fsr_vis_d_ln(p) = albd(p,1)*forc_solad(g,1) - fsr_nir_d_ln(p) = albd(p,2)*forc_solad(g,2) + fsds_vis_d_ln(p) = forc_solad_col(c,1) + fsds_nir_d_ln(p) = forc_solad_col(c,2) + fsr_vis_d_ln(p) = albd(p,1)*forc_solad_col(c,1) + fsr_nir_d_ln(p) = albd(p,2)*forc_solad_col(c,2) fsds_vis_i_ln(p) = forc_solai(g,1) parveg_ln(p) = parveg(p) else @@ -935,8 +938,8 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & end if if (use_SSRE) then if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then - fsrSF_vis_d_ln(p) = albdSF(p,1)*forc_solad(g,1) - fsrSF_nir_d_ln(p) = albdSF(p,2)*forc_solad(g,2) + fsrSF_vis_d_ln(p) = albdSF(p,1)*forc_solad_col(c,1) + fsrSF_nir_d_ln(p) = albdSF(p,2)*forc_solad_col(c,2) else fsrSF_vis_d_ln(p) = spval fsrSF_nir_d_ln(p) = spval @@ -946,8 +949,8 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! (OPTIONAL) c = patch%column(p) if (snl(c) < 0) then - fsds_sno_vd(p) = forc_solad(g,1) - fsds_sno_nd(p) = forc_solad(g,2) + fsds_sno_vd(p) = forc_solad_col(c,1) + fsds_sno_nd(p) = forc_solad_col(c,2) fsds_sno_vi(p) = forc_solai(g,1) fsds_sno_ni(p) = forc_solai(g,2) @@ -972,6 +975,7 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & do fp = 1,num_urbanp p = filter_urbanp(fp) g = patch%gridcell(p) + c = patch%column(p) if(elai(p)==0.0_r8.and.fabd(p,1)>0._r8)then if ( local_debug ) write(iulog,*) 'absorption without LAI',elai(p),tlai(p),fabd(p,1),p @@ -979,15 +983,15 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! Solar incident - fsds_vis_d(p) = forc_solad(g,1) - fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_d(p) = forc_solad_col(c,1) + fsds_nir_d(p) = forc_solad_col(c,2) fsds_vis_i(p) = forc_solai(g,1) fsds_nir_i(p) = forc_solai(g,2) ! Determine local noon incident solar if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then - fsds_vis_d_ln(p) = forc_solad(g,1) - fsds_nir_d_ln(p) = forc_solad(g,2) + fsds_vis_d_ln(p) = forc_solad_col(c,1) + fsds_nir_d_ln(p) = forc_solad_col(c,2) fsds_vis_i_ln(p) = forc_solai(g,1) parveg_ln(p) = 0._r8 else @@ -1000,8 +1004,8 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! Solar reflected ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) - fsr_vis_d(p) = albd(p,1) * forc_solad(g,1) - fsr_nir_d(p) = albd(p,2) * forc_solad(g,2) + fsr_vis_d(p) = albd(p,1) * forc_solad_col(c,1) + fsr_nir_d(p) = albd(p,2) * forc_solad_col(c,2) fsr_vis_i(p) = albi(p,1) * forc_solai(g,1) fsr_nir_i(p) = albi(p,2) * forc_solai(g,2) diff --git a/src/biogeophys/SurfaceWaterMod.F90 b/src/biogeophys/SurfaceWaterMod.F90 index b293dd792c..562c64cc18 100644 --- a/src/biogeophys/SurfaceWaterMod.F90 +++ b/src/biogeophys/SurfaceWaterMod.F90 @@ -456,6 +456,7 @@ subroutine QflxH2osfcSurf(bounds, num_hydrologyc, filter_hydrologyc, & real(r8) :: dtime ! land model time step (sec) real(r8) :: frac_infclust ! fraction of submerged area that is connected real(r8) :: k_wet ! linear reservoir coefficient for h2osfc + real(r8),parameter :: min_hill_slope = 1e-3_r8! minimum value of hillslope for outflow character(len=*), parameter :: subname = 'QflxH2osfcSurf' !----------------------------------------------------------------------- @@ -483,6 +484,10 @@ subroutine QflxH2osfcSurf(bounds, num_hydrologyc, filter_hydrologyc, & if(h2osfc(c) > h2osfc_thresh(c) .and. h2osfcflag/=0) then ! spatially variable k_wet k_wet=1.0e-4_r8 * sin((rpi/180._r8) * topo_slope(c)) + if (col%is_hillslope_column(c)) then + ! require a minimum value to ensure non-zero outflow + k_wet = 1e-4_r8 * max(col%hill_slope(c),min_hill_slope) + endif qflx_h2osfc_surf(c) = k_wet * frac_infclust * (h2osfc(c) - h2osfc_thresh(c)) qflx_h2osfc_surf(c)=min(qflx_h2osfc_surf(c),(h2osfc(c) - h2osfc_thresh(c))/dtime) diff --git a/src/biogeophys/UrbanRadiationMod.F90 b/src/biogeophys/UrbanRadiationMod.F90 index 0b6412f2d2..ccb3f196b7 100644 --- a/src/biogeophys/UrbanRadiationMod.F90 +++ b/src/biogeophys/UrbanRadiationMod.F90 @@ -117,9 +117,9 @@ subroutine UrbanRadiation (bounds , & canyon_hwr => lun%canyon_hwr , & ! Input: [real(r8) (:) ] ratio of building height to street width wtroad_perv => lun%wtroad_perv , & ! Input: [real(r8) (:) ] weight of pervious road wrt total road - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) + forc_solad => atm2lnd_inst%forc_solad_not_downscaled_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) - forc_solar => atm2lnd_inst%forc_solar_grc , & ! Input: [real(r8) (:) ] incident solar radiation (W/m**2) + forc_solar => atm2lnd_inst%forc_solar_not_downscaled_grc , & ! Input: [real(r8) (:) ] incident solar radiation (W/m**2) forc_lwrad => atm2lnd_inst%forc_lwrad_not_downscaled_grc , & ! Input: [real(r8) (:) ] downward infrared (longwave) radiation (W/m**2) frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) diff --git a/src/biogeophys/WaterDiagnosticBulkType.F90 b/src/biogeophys/WaterDiagnosticBulkType.F90 index 057062777f..dd556a2df6 100644 --- a/src/biogeophys/WaterDiagnosticBulkType.F90 +++ b/src/biogeophys/WaterDiagnosticBulkType.F90 @@ -16,7 +16,7 @@ module WaterDiagnosticBulkType use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type use abortutils , only : endrun - use clm_varctl , only : use_cn, iulog, use_luna + use clm_varctl , only : use_cn, iulog, use_luna, use_hillslope use clm_varpar , only : nlevgrnd, nlevsno, nlevcan, nlevsoi use clm_varcon , only : spval use LandunitType , only : lun @@ -83,6 +83,9 @@ module WaterDiagnosticBulkType real(r8), pointer :: qflx_prec_intr_patch (:) ! patch interception of precipitation (mm H2O/s) real(r8), pointer :: qflx_prec_grnd_col (:) ! col water onto ground including canopy runoff (mm H2O/s) + ! Hillslope stream variables + real(r8), pointer :: stream_water_depth_lun (:) ! landunit depth of water in the streams (m) + contains ! Public interfaces @@ -231,6 +234,7 @@ subroutine InitBulkAllocate(this, bounds) allocate(this%fdry_patch (begp:endp)) ; this%fdry_patch (:) = nan allocate(this%qflx_prec_intr_patch (begp:endp)) ; this%qflx_prec_intr_patch (:) = nan allocate(this%qflx_prec_grnd_col (begc:endc)) ; this%qflx_prec_grnd_col (:) = nan + allocate(this%stream_water_depth_lun (begl:endl)) ; this%stream_water_depth_lun (:) = nan end subroutine InitBulkAllocate @@ -252,12 +256,14 @@ subroutine InitBulkHistory(this, bounds) ! !LOCAL VARIABLES: integer :: begp, endp integer :: begc, endc + integer :: begl, endl integer :: begg, endg real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays !------------------------------------------------------------------------ begp = bounds%begp; endp= bounds%endp begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl begg = bounds%begg; endg= bounds%endg this%h2osno_total_col(begc:endc) = spval @@ -580,6 +586,14 @@ subroutine InitBulkHistory(this, bounds) long_name=this%info%lname('interception'), & ptr_patch=this%qflx_prec_intr_patch, set_lake=0._r8) + if (use_hillslope) then + this%stream_water_depth_lun(begl:endl) = spval + call hist_addfld1d (fname=this%info%fname('STREAM_WATER_DEPTH'), & + units='m', avgflag='A', & + long_name=this%info%lname('depth of water in stream channel (hillslope hydrology only)'), & + ptr_lunit=this%stream_water_depth_lun, l2g_scale_type='natveg', default='inactive') + endif + end subroutine InitBulkHistory !----------------------------------------------------------------------- diff --git a/src/biogeophys/WaterFluxType.F90 b/src/biogeophys/WaterFluxType.F90 index f7c55d44e1..23980a21c9 100644 --- a/src/biogeophys/WaterFluxType.F90 +++ b/src/biogeophys/WaterFluxType.F90 @@ -10,7 +10,7 @@ module WaterFluxType use clm_varpar , only : nlevsno, nlevsoi use clm_varcon , only : spval use decompMod , only : bounds_type - use decompMod , only : subgrid_level_patch, subgrid_level_column, subgrid_level_gridcell + use decompMod , only : subgrid_level_patch, subgrid_level_column, subgrid_level_landunit, subgrid_level_gridcell use LandunitType , only : lun use ColumnType , only : col use AnnualFluxDribbler, only : annual_flux_dribbler_type, annual_flux_dribbler_gridcell @@ -26,7 +26,7 @@ module WaterFluxType class(water_info_base_type), pointer :: info - ! water fluxes are in units or mm/s + ! water fluxes are in units of mm/s real(r8), pointer :: qflx_through_snow_patch (:) ! patch canopy throughfall of snow (mm H2O/s) real(r8), pointer :: qflx_through_liq_patch (:) ! patch canopy throughfal of liquid (rain+irrigation) (mm H2O/s) @@ -72,6 +72,10 @@ module WaterFluxType real(r8), pointer :: qflx_infl_col (:) ! col infiltration (mm H2O /s) real(r8), pointer :: qflx_surf_col (:) ! col total surface runoff (mm H2O /s) real(r8), pointer :: qflx_drain_col (:) ! col sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_latflow_in_col (:) ! col hillslope lateral flow input (mm/s) + real(r8), pointer :: qflx_latflow_out_col (:) ! col hillslope lateral flow output (mm/s) + real(r8), pointer :: volumetric_discharge_col (:) ! col hillslope discharge (m3/s) + real(r8), pointer :: volumetric_streamflow_lun(:) ! lun stream discharge (m3/s) real(r8), pointer :: qflx_drain_perched_col (:) ! col sub-surface runoff from perched wt (mm H2O /s) real(r8), pointer :: qflx_top_soil_col (:) ! col net water input into soil from top (mm/s) real(r8), pointer :: qflx_floodc_col (:) ! col flood water flux at column level @@ -278,6 +282,18 @@ subroutine InitAllocate(this, bounds, tracer_vars) call AllocateVar1d(var = this%qflx_drain_perched_col, name = 'qflx_drain_perched_col', & container = tracer_vars, & bounds = bounds, subgrid_level = subgrid_level_column) + call AllocateVar1d(var = this%qflx_latflow_in_col, name = 'qflx_latflow_in_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_column) + call AllocateVar1d(var = this%qflx_latflow_out_col, name = 'qflx_latflow_out_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_column) + call AllocateVar1d(var = this%volumetric_discharge_col, name = 'volumetric_discharge_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_column) + call AllocateVar1d(var = this%volumetric_streamflow_lun, name = 'volumetric_streamflow_lun', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_landunit) call AllocateVar1d(var = this%qflx_top_soil_col, name = 'qflx_top_soil_col', & container = tracer_vars, & bounds = bounds, subgrid_level = subgrid_level_column) @@ -386,6 +402,8 @@ subroutine InitHistory(this, bounds) ! ! !USES: use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + use clm_varctl , only : use_hillslope, use_hillslope_routing + ! ! !ARGUMENTS: class(waterflux_type), intent(in) :: this @@ -394,12 +412,14 @@ subroutine InitHistory(this, bounds) ! !LOCAL VARIABLES: integer :: begp, endp integer :: begc, endc + integer :: begl, endl integer :: begg, endg real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays !------------------------------------------------------------------------ begp = bounds%begp; endp= bounds%endp begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl begg = bounds%begg; endg= bounds%endg this%qflx_through_liq_patch(begp:endp) = spval @@ -483,6 +503,37 @@ subroutine InitHistory(this, bounds) long_name=this%info%lname('sub-surface drainage'), & ptr_col=this%qflx_drain_col, c2l_scale_type='urbanf') + if (use_hillslope) then + this%qflx_latflow_out_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QLATFLOWOUT'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('hillcol lateral outflow'), & + l2g_scale_type='natveg', c2l_scale_type='urbanf', & + ptr_col=this%qflx_latflow_out_col) + + this%volumetric_discharge_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('VOLUMETRIC_DISCHARGE'), & + units='m3/s', & + avgflag='A', & + long_name=this%info%lname('hillslope discharge from column'), & + l2g_scale_type='natveg', c2l_scale_type='urbanf', & + ptr_col=this%volumetric_discharge_col,default='inactive') + + if (use_hillslope_routing) then + this%volumetric_streamflow_lun(begl:endl) = spval + call hist_addfld1d ( & + fname=this%info%fname('VOLUMETRIC_STREAMFLOW'), & + units='m3/s', & + avgflag='A', & + long_name=this%info%lname('volumetric streamflow from hillslope'), & + l2g_scale_type='natveg', & + ptr_lunit=this%volumetric_streamflow_lun) + endif + endif + this%qflx_drain_perched_col(begc:endc) = spval call hist_addfld1d ( & fname=this%info%fname('QDRAI_PERCH'), & @@ -810,6 +861,8 @@ subroutine InitCold(this, bounds) ! ! !USES: use landunit_varcon, only : istsoil, istcrop + use clm_varctl , only : use_hillslope_routing + ! ! !ARGUMENTS: class(waterflux_type), intent(in) :: this @@ -861,9 +914,19 @@ subroutine InitCold(this, bounds) if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then this%qflx_drain_col(c) = 0._r8 this%qflx_surf_col(c) = 0._r8 + this%qflx_latflow_in_col(c) = 0._r8 + this%qflx_latflow_out_col(c) = 0._r8 + this%volumetric_discharge_col(c) = 0._r8 end if end do - + if (use_hillslope_routing) then + do l = bounds%begl, bounds%endl + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%volumetric_streamflow_lun(l) = 0._r8 + end if + end do + endif + end subroutine InitCold !------------------------------------------------------------------------ diff --git a/src/biogeophys/WaterStateType.F90 b/src/biogeophys/WaterStateType.F90 index cdbefa2a04..390e9e8691 100644 --- a/src/biogeophys/WaterStateType.F90 +++ b/src/biogeophys/WaterStateType.F90 @@ -12,10 +12,10 @@ module WaterStateType use shr_log_mod , only : errMsg => shr_log_errMsg use abortutils , only : endrun use decompMod , only : bounds_type - use decompMod , only : subgrid_level_patch, subgrid_level_column, subgrid_level_gridcell + use decompMod , only : subgrid_level_patch, subgrid_level_column, subgrid_level_landunit, subgrid_level_gridcell use clm_varctl , only : use_bedrock, use_excess_ice, iulog use spmdMod , only : masterproc - use clm_varctl , only : use_fates + use clm_varctl , only : use_fates, use_hillslope use clm_varpar , only : nlevgrnd, nlevsoi, nlevurb, nlevmaxurbgrnd, nlevsno use clm_varcon , only : spval use LandunitType , only : lun @@ -58,6 +58,9 @@ module WaterStateType type(excessicestream_type), private :: exicestream ! stream type for excess ice initialization NUOPC only + ! Hillslope stream variables + real(r8), pointer :: stream_water_volume_lun(:) ! landunit volume of water in the streams (m3) + contains procedure, public :: Init @@ -158,6 +161,9 @@ subroutine InitAllocate(this, bounds, tracer_vars) call AllocateVar1d(var = this%dynbal_baseline_ice_col, name = 'dynbal_baseline_ice_col', & container = tracer_vars, & bounds = bounds, subgrid_level = subgrid_level_column) + call AllocateVar1d(var = this%stream_water_volume_lun, name = 'stream_water_volume_lun', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_landunit) !excess ice vars call AllocateVar2d(var = this%excess_ice_col, name = 'excess_ice_col', & container = tracer_vars, & @@ -178,6 +184,7 @@ subroutine InitHistory(this, bounds, use_aquifer_layer) ! !USES: use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal use clm_varctl , only : use_soil_moisture_streams + use GridcellType , only : grc ! ! !ARGUMENTS: class(waterstate_type), intent(in) :: this @@ -187,12 +194,14 @@ subroutine InitHistory(this, bounds, use_aquifer_layer) ! !LOCAL VARIABLES: integer :: begp, endp integer :: begc, endc + integer :: begl, endl integer :: begg, endg real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays !------------------------------------------------------------------------ begp = bounds%begp; endp= bounds%endp begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl begg = bounds%begg; endg= bounds%endg data2dptr => this%h2osoi_liq_col(:,-nlevsno+1:0) @@ -284,6 +293,14 @@ subroutine InitHistory(this, bounds, use_aquifer_layer) ptr_col=this%wa_col, l2g_scale_type='veg') end if + if (use_hillslope) then + this%stream_water_volume_lun(begl:endl) = spval + call hist_addfld1d (fname=this%info%fname('STREAM_WATER_VOLUME'), units='m3', & + avgflag='A', & + long_name=this%info%lname('volume of water in stream channel (hillslope hydrology only)'), & + ptr_lunit=this%stream_water_volume_lun, l2g_scale_type='natveg', default='inactive') + end if + ! Add excess ice fields to history if (use_excess_ice) then @@ -345,7 +362,7 @@ subroutine InitCold(this, bounds, & this%h2osfc_col(bounds%begc:bounds%endc) = 0._r8 this%snocan_patch(bounds%begp:bounds%endp) = 0._r8 this%liqcan_patch(bounds%begp:bounds%endp) = 0._r8 - + this%stream_water_volume_lun(bounds%begl:bounds%endl) = 0._r8 !-------------------------------------------- ! Set soil water @@ -709,6 +726,13 @@ subroutine Restart(this, bounds, ncid, flag, & units='kg/m2', & interpinic_flag='interp', readvar=readvar, data=this%dynbal_baseline_ice_col) + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('STREAM_WATER_VOLUME'), & + xtype=ncd_double, & + dim1name='landunit', & + long_name=this%info%lname('water in stream channel'), & + units='m3', & + interpinic_flag='interp', readvar=readvar, data=this%stream_water_volume_lun) ! Restart excess ice vars if (.not. use_excess_ice) then ! no need to even define the restart vars diff --git a/src/biogeophys/Wateratm2lndBulkType.F90 b/src/biogeophys/Wateratm2lndBulkType.F90 index 03ee7522f3..4aacbe11c2 100644 --- a/src/biogeophys/Wateratm2lndBulkType.F90 +++ b/src/biogeophys/Wateratm2lndBulkType.F90 @@ -30,6 +30,8 @@ module Wateratm2lndBulkType real(r8), pointer :: volrmch_grc (:) ! rof volr main channel (m3) real(r8), pointer :: volr_grc (:) ! rof volr total volume (m3) + real(r8), pointer :: tdepth_grc (:) ! rof tributary water depth (m) + real(r8), pointer :: tdepthmax_grc (:) ! rof tributary bankfull water depth (m) real(r8), pointer :: forc_rh_grc (:) ! atmospheric relative humidity (%) real(r8) , pointer :: prec365_col (:) ! col 365-day running mean of tot. precipitation (see comment in UpdateAccVars regarding why this is col-level despite other prec accumulators being patch-level) real(r8) , pointer :: prec60_patch (:) ! patch 60-day running mean of tot. precipitation (mm/s) @@ -117,6 +119,8 @@ subroutine InitBulkAllocate(this, bounds) begc = bounds%begc; endc= bounds%endc begg = bounds%begg; endg= bounds%endg + allocate(this%tdepth_grc (begg:endg)) ; this%tdepth_grc (:) = ival + allocate(this%tdepthmax_grc (begg:endg)) ; this%tdepthmax_grc (:) = ival allocate(this%volr_grc (begg:endg)) ; this%volr_grc (:) = ival allocate(this%volrmch_grc (begg:endg)) ; this%volrmch_grc (:) = ival allocate(this%forc_rh_grc (begg:endg)) ; this%forc_rh_grc (:) = ival @@ -154,6 +158,15 @@ subroutine InitBulkHistory(this, bounds) begp = bounds%begp; endp= bounds%endp begg = bounds%begg; endg= bounds%endg + this%tdepth_grc(begg:endg) = spval + call hist_addfld1d (fname='TDEPTH', units='m', & + avgflag='A', long_name='tributary water depth', & + ptr_lnd=this%tdepth_grc, default = 'inactive') + + this%tdepthmax_grc(begg:endg) = spval + call hist_addfld1d (fname='TDEPTHMAX', units='m', & + avgflag='A', long_name='tributary bankfull water depth', & + ptr_lnd=this%tdepthmax_grc, default = 'inactive') this%volr_grc(begg:endg) = spval call hist_addfld1d (fname=this%info%fname('VOLR'), units='m3', & @@ -462,6 +475,8 @@ subroutine Clean(this) ! rof->lnd deallocate(this%forc_flood_grc) + deallocate(this%tdepth_grc) + deallocate(this%tdepthmax_grc) deallocate(this%volr_grc) deallocate(this%volrmch_grc) diff --git a/src/biogeophys/Waterlnd2atmType.F90 b/src/biogeophys/Waterlnd2atmType.F90 index 54972e9b00..80214bebbb 100644 --- a/src/biogeophys/Waterlnd2atmType.F90 +++ b/src/biogeophys/Waterlnd2atmType.F90 @@ -32,6 +32,7 @@ module Waterlnd2atmType real(r8), pointer :: qflx_rofliq_qsub_grc (:) ! rof liq -- subsurface runoff component real(r8), pointer :: qflx_rofliq_qgwl_grc (:) ! rof liq -- glacier, wetland and lakes water balance residual component real(r8), pointer :: qflx_rofliq_drain_perched_grc (:) ! rof liq -- perched water table runoff component + real(r8), pointer :: qflx_rofliq_stream_grc (:) ! rof liq -- stream channel runoff component real(r8), pointer :: qflx_ice_runoff_col(:) ! rof ice forcing, col level real(r8), pointer :: qflx_rofice_grc (:) ! rof ice forcing, grc level real(r8), pointer :: qflx_liq_from_ice_col(:) ! liquid runoff from converted ice runoff @@ -120,6 +121,10 @@ subroutine InitAllocate(this, bounds, tracer_vars) container = tracer_vars, & bounds = bounds, subgrid_level = subgrid_level_gridcell, & ival=ival) + call AllocateVar1d(var = this%qflx_rofliq_stream_grc, name = 'qflx_rofliq_stream_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = subgrid_level_gridcell, & + ival=ival) call AllocateVar1d(var = this%qflx_ice_runoff_col, name = 'qflx_ice_runoff_col', & container = tracer_vars, & bounds = bounds, subgrid_level = subgrid_level_column, & diff --git a/src/biogeophys/test/CMakeLists.txt b/src/biogeophys/test/CMakeLists.txt index 49f80533de..5c15858210 100644 --- a/src/biogeophys/test/CMakeLists.txt +++ b/src/biogeophys/test/CMakeLists.txt @@ -1,6 +1,7 @@ add_subdirectory(Daylength_test) add_subdirectory(Irrigation_test) add_subdirectory(HumanStress_test) +add_subdirectory(HillslopeHydrology_test) add_subdirectory(SnowHydrology_test) add_subdirectory(Photosynthesis_test) add_subdirectory(Balance_test) diff --git a/src/biogeophys/test/HillslopeHydrology_test/CMakeLists.txt b/src/biogeophys/test/HillslopeHydrology_test/CMakeLists.txt new file mode 100644 index 0000000000..f40baf96ed --- /dev/null +++ b/src/biogeophys/test/HillslopeHydrology_test/CMakeLists.txt @@ -0,0 +1,6 @@ +set (pfunit_sources + test_hillslopehydrologyUtils.pf) + +add_pfunit_ctest(HillslopeHydrologyUtils + TEST_SOURCES "${pfunit_sources}" + LINK_LIBRARIES clm csm_share esmf_wrf_timemgr) diff --git a/src/biogeophys/test/HillslopeHydrology_test/test_hillslopehydrologyUtils.pf b/src/biogeophys/test/HillslopeHydrology_test/test_hillslopehydrologyUtils.pf new file mode 100644 index 0000000000..63db42cffd --- /dev/null +++ b/src/biogeophys/test/HillslopeHydrology_test/test_hillslopehydrologyUtils.pf @@ -0,0 +1,249 @@ +module test_hillslopehydrologyUtils + + ! Tests of the HillslopeHydrologyUtils module + + use funit + use unittestSubgridMod + use ColumnType , only : col + use LandunitType , only : lun + use landunit_varcon , only : istwet + use decompMod , only : bounds_type + use clm_varpar , only : nlevsoi, nlevgrnd + use shr_kind_mod , only : r8 => shr_kind_r8 + use HillslopeHydrologyUtilsMod, only : HillslopeSoilThicknessProfile_linear + + implicit none + + ! From clm_instInit + real(r8), parameter :: soil_depth_lowland = 8.5_r8 + real(r8), parameter :: soil_depth_upland = 2._r8 + + integer, parameter :: nbedrock_dummy_value = 9999 + + @TestCase + type, extends(TestCase) :: TestInit + contains + procedure :: setUp + procedure :: tearDown + end type TestInit + +contains + + subroutine setUp(this) + ! Set up variables needed for tests: various subgrid type variables, along with + ! bounds. + ! + class(TestInit), intent(inout) :: this + integer :: g, l, c + + ! Set up subgrid structure + ! The weights (of both landunits and columns) and column types in the following are + ! arbitrary, since they are not important for these tests + + call unittest_subgrid_setup_start() + + ! Set up gridcell with one landunit and two columns + call unittest_add_gridcell() + call unittest_add_landunit(my_gi=gi, ltype=istwet, wtgcell=0.25_r8) + call unittest_add_column(my_li=li, ctype=1, wtlunit=0.5_r8) + call unittest_add_column(my_li=li, ctype=1, wtlunit=0.5_r8) + + call unittest_subgrid_setup_end() + + ! These will be enabled by specific tests + col%active(begc:endc) = .false. + col%is_hillslope_column(begc:endc) = .false. + + ! Set up hill_distance + l = bounds%begl + do c = lun%coli(l), lun%colf(l) + col%hill_distance(c) = real(c, kind=r8) + end do + + + end subroutine setUp + + subroutine tearDown(this) + ! clean up stuff set up in setup() + use clm_varcon, only: clm_varcon_clean + class(TestInit), intent(inout) :: this + + call unittest_subgrid_teardown() + call clm_varcon_clean() + + end subroutine tearDown + + ! Set up ground/soil structure + subroutine ground_a(bounds) + use clm_varcon, only: clm_varcon_init, zisoi + type(bounds_type), intent(in) :: bounds + real(r8), allocatable :: my_zisoi(:) + + nlevsoi = 5 + allocate(my_zisoi(1:nlevsoi)) + my_zisoi = [0.01_r8, 0.02_r8, 2._r8, 4._r8, 6._r8] + nlevgrnd = size(my_zisoi) + call clm_varcon_init( is_simple_buildtemp = .true.) + zisoi(0) = 0._r8 + zisoi(1:nlevgrnd) = my_zisoi(:) + col%nbedrock(bounds%begc:bounds%endc) = nbedrock_dummy_value + + deallocate(my_zisoi) + end subroutine ground_a + + ! Set up ground/soil structure + subroutine ground_b(bounds) + use clm_varcon, only: clm_varcon_init, zisoi + type(bounds_type), intent(in) :: bounds + real(r8), allocatable :: my_zisoi(:) + + nlevsoi = 3 + allocate(my_zisoi(1:nlevsoi)) + my_zisoi = [0.01_r8, 0.02_r8, 1._r8] + nlevgrnd = size(my_zisoi) + call clm_varcon_init( is_simple_buildtemp = .true.) + zisoi(0) = 0._r8 + zisoi(1:nlevgrnd) = my_zisoi(:) + col%nbedrock(bounds%begc:bounds%endc) = nbedrock_dummy_value + + deallocate(my_zisoi) + end subroutine ground_b + + @Test + subroutine test_HillslopeSoilThicknessProfile_linear(this) + class(TestInit), intent(inout) :: this + integer, allocatable :: nbedrock_expected(:) + integer :: l, c + + l = bounds%begl + + call ground_a(bounds) + col%active(bounds%begc:bounds%endc) = .true. + col%is_hillslope_column(bounds%begc:bounds%endc) = .true. + + ! Get expected values + ! Column 1 soil_depth_col = 8.5 + ! Column 2 soil_depth_col = 2.0 + allocate(nbedrock_expected(bounds%begc:bounds%endc)) + nbedrock_expected(lun%coli(l)) = nbedrock_dummy_value + nbedrock_expected(lun%coli(l) + 1) = 3 + + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland) + + @assertEqual(nbedrock_expected(lun%coli(l):lun%colf(l)), col%nbedrock(lun%coli(l):lun%colf(l))) + + deallocate(nbedrock_expected) + + end subroutine test_HillslopeSoilThicknessProfile_linear + + @Test + subroutine test_HillslopeSoilThicknessProfile_linear_tooshallow(this) + class(TestInit), intent(inout) :: this + integer, allocatable :: nbedrock_expected(:) + integer :: l, c + + l = bounds%begl + + call ground_b(bounds) + col%active(bounds%begc:bounds%endc) = .true. + col%is_hillslope_column(bounds%begc:bounds%endc) = .true. + + ! Get expected values + ! Column 1 soil_depth_col = 8.5 + ! Column 2 soil_depth_col = 2.0; still too deep for ground_b() + allocate(nbedrock_expected(bounds%begc:bounds%endc)) + nbedrock_expected(lun%coli(l)) = nbedrock_dummy_value + nbedrock_expected(lun%coli(l) + 1) = nbedrock_dummy_value + + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland) + + @assertEqual(nbedrock_expected(lun%coli(l):lun%colf(l)), col%nbedrock(lun%coli(l):lun%colf(l))) + + deallocate(nbedrock_expected) + + end subroutine test_HillslopeSoilThicknessProfile_linear_tooshallow + + @Test + subroutine test_HillslopeSoilThicknessProfile_linear_noslope(this) + class(TestInit), intent(inout) :: this + integer, allocatable :: nbedrock_expected(:) + integer :: l, c + real(r8) :: toosmall_distance + + l = bounds%begl + + call ground_a(bounds) + col%active(bounds%begc:bounds%endc) = .true. + col%is_hillslope_column(bounds%begc:bounds%endc) = .true. + + ! Get expected values, setting toosmall_distance to something high enough that the (abs(max_hill_dist - min_hill_dist) > toosmall_distance) conditional will fail, causing m = 0.0 + toosmall_distance = 100._r8 + ! Column 1 soil_depth_col = 2.0 + ! Column 2 soil_depth_col = 2.0 + allocate(nbedrock_expected(bounds%begc:bounds%endc)) + nbedrock_expected(lun%coli(l)) = 3 + nbedrock_expected(lun%coli(l) + 1) = 3 + + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland, toosmall_distance_in=toosmall_distance) + + @assertEqual(nbedrock_expected(lun%coli(l):lun%colf(l)), col%nbedrock(lun%coli(l):lun%colf(l))) + + deallocate(nbedrock_expected) + + end subroutine test_HillslopeSoilThicknessProfile_linear_noslope + + @Test + subroutine test_HillslopeSoilThicknessProfile_linear_inactive(this) + class(TestInit), intent(inout) :: this + integer, allocatable :: nbedrock_expected(:) + integer :: l, c + + l = bounds%begl + + call ground_a(bounds) + col%active(bounds%begc:bounds%endc) = .false. + col%is_hillslope_column(bounds%begc:bounds%endc) = .true. + + ! Get expected values + ! Column 1 soil_depth_col = 8.5 + ! Column 2 soil_depth_col = 2.0, but not active + allocate(nbedrock_expected(bounds%begc:bounds%endc)) + nbedrock_expected(lun%coli(l)) = nbedrock_dummy_value + nbedrock_expected(lun%coli(l) + 1) = nbedrock_dummy_value + + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland) + + @assertEqual(nbedrock_expected(lun%coli(l):lun%colf(l)), col%nbedrock(lun%coli(l):lun%colf(l))) + + deallocate(nbedrock_expected) + + end subroutine test_HillslopeSoilThicknessProfile_linear_inactive + + @Test + subroutine test_HillslopeSoilThicknessProfile_linear_nohillslope(this) + class(TestInit), intent(inout) :: this + integer, allocatable :: nbedrock_expected(:) + integer :: l, c + + l = bounds%begl + + call ground_a(bounds) + col%active(bounds%begc:bounds%endc) = .true. + col%is_hillslope_column(bounds%begc:bounds%endc) = .false. + + ! Get expected values + ! Column 1 soil_depth_col = 8.5 + ! Column 2 soil_depth_col = 2.0, but not is_hillslope_column + allocate(nbedrock_expected(bounds%begc:bounds%endc)) + nbedrock_expected(lun%coli(l)) = nbedrock_dummy_value + nbedrock_expected(lun%coli(l) + 1) = nbedrock_dummy_value + + call HillslopeSoilThicknessProfile_linear(bounds, soil_depth_lowland, soil_depth_upland) + + @assertEqual(nbedrock_expected(lun%coli(l):lun%colf(l)), col%nbedrock(lun%coli(l):lun%colf(l))) + + deallocate(nbedrock_expected) + + end subroutine test_HillslopeSoilThicknessProfile_linear_nohillslope + +end module test_hillslopehydrologyUtils diff --git a/src/cpl/lilac/lnd_import_export.F90 b/src/cpl/lilac/lnd_import_export.F90 index 281666c3e7..bab24ed37f 100644 --- a/src/cpl/lilac/lnd_import_export.F90 +++ b/src/cpl/lilac/lnd_import_export.F90 @@ -154,11 +154,11 @@ subroutine import_fields( importState, bounds, first_call, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport(importState, 'c2l_fb_atm', 'Faxa_swvdr', bounds, & - output=atm2lnd_inst%forc_solad_grc(:,1), rc=rc) + output=atm2lnd_inst%forc_solad_not_downscaled_grc(:,1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport(importState, 'c2l_fb_atm', 'Faxa_swndr', bounds, & - output=atm2lnd_inst%forc_solad_grc(:,2), rc=rc) + output=atm2lnd_inst%forc_solad_not_downscaled_grc(:,2), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport(importState, 'c2l_fb_atm', 'Faxa_swvdf', bounds, & diff --git a/src/cpl/mct/lnd_import_export.F90 b/src/cpl/mct/lnd_import_export.F90 index 3f7e67af68..537abd49d9 100644 --- a/src/cpl/mct/lnd_import_export.F90 +++ b/src/cpl/mct/lnd_import_export.F90 @@ -10,6 +10,7 @@ module lnd_import_export use Waterlnd2atmBulkType , only: waterlnd2atmbulk_type use Wateratm2lndBulkType , only: wateratm2lndbulk_type use clm_cpl_indices + use GridcellType , only : grc ! implicit none !=============================================================================== @@ -96,8 +97,8 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst, wat atm2lnd_inst%forc_topo_grc(g) = x2l(index_x2l_Sa_topo,i) ! Atm surface height (m) atm2lnd_inst%forc_u_grc(g) = x2l(index_x2l_Sa_u,i) ! forc_uxy Atm state m/s atm2lnd_inst%forc_v_grc(g) = x2l(index_x2l_Sa_v,i) ! forc_vxy Atm state m/s - atm2lnd_inst%forc_solad_grc(g,2) = x2l(index_x2l_Faxa_swndr,i) ! forc_sollxy Atm flux W/m^2 - atm2lnd_inst%forc_solad_grc(g,1) = x2l(index_x2l_Faxa_swvdr,i) ! forc_solsxy Atm flux W/m^2 + atm2lnd_inst%forc_solad_not_downscaled_grc(g,2) = x2l(index_x2l_Faxa_swndr,i) ! forc_sollxy Atm flux W/m^2 + atm2lnd_inst%forc_solad_not_downscaled_grc(g,1) = x2l(index_x2l_Faxa_swvdr,i) ! forc_solsxy Atm flux W/m^2 atm2lnd_inst%forc_solai_grc(g,2) = x2l(index_x2l_Faxa_swndf,i) ! forc_solldxy Atm flux W/m^2 atm2lnd_inst%forc_solai_grc(g,1) = x2l(index_x2l_Faxa_swvdf,i) ! forc_solsdxy Atm flux W/m^2 diff --git a/src/cpl/nuopc/lnd_import_export.F90 b/src/cpl/nuopc/lnd_import_export.F90 index 5ed5ff76d1..11cc807640 100644 --- a/src/cpl/nuopc/lnd_import_export.F90 +++ b/src/cpl/nuopc/lnd_import_export.F90 @@ -9,7 +9,7 @@ module lnd_import_export use NUOPC_Model , only : NUOPC_ModelGet use shr_kind_mod , only : r8 => shr_kind_r8, cx=>shr_kind_cx, cxx=>shr_kind_cxx, cs=>shr_kind_cs use shr_sys_mod , only : shr_sys_abort - use clm_varctl , only : iulog + use clm_varctl , only : iulog, use_hillslope_routing use clm_time_manager , only : get_nstep use decompmod , only : bounds_type, get_proc_bounds use lnd2atmType , only : lnd2atm_type @@ -99,6 +99,8 @@ module lnd_import_export character(*), parameter :: Flrr_flood = 'Flrr_flood' character(*), parameter :: Flrr_volr = 'Flrr_volr' character(*), parameter :: Flrr_volrmch = 'Flrr_volrmch' + character(*), parameter :: Sr_tdepth = 'Sr_tdepth' + character(*), parameter :: Sr_tdepth_max = 'Sr_tdepth_max' character(*), parameter :: Sg_ice_covered_elev = 'Sg_ice_covered_elev' character(*), parameter :: Sg_topo_elev = 'Sg_topo_elev' character(*), parameter :: Flgg_hflx_elev = 'Flgg_hflx_elev' @@ -388,6 +390,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, glc_present, cism_evolve, r call fldlist_add(fldsToLnd_num, fldsToLnd, Flrr_flood ) call fldlist_add(fldsToLnd_num, fldsToLnd, Flrr_volr ) call fldlist_add(fldsToLnd_num, fldsToLnd, Flrr_volrmch ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sr_tdepth ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sr_tdepth_max ) end if if (glc_present) then @@ -549,9 +553,9 @@ subroutine import_fields( gcomp, bounds, glc_present, rof_prognostic, & if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport_1d(importState, Faxa_lwdn , atm2lnd_inst%forc_lwrad_not_downscaled_grc(begg:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport_1d(importState, Faxa_swvdr, atm2lnd_inst%forc_solad_grc(begg:,1), rc=rc) + call state_getimport_1d(importState, Faxa_swvdr, atm2lnd_inst%forc_solad_not_downscaled_grc(begg:,1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport_1d(importState, Faxa_swndr, atm2lnd_inst%forc_solad_grc(begg:,2), rc=rc) + call state_getimport_1d(importState, Faxa_swndr, atm2lnd_inst%forc_solad_not_downscaled_grc(begg:,2), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport_1d(importState, Faxa_swvdf, atm2lnd_inst%forc_solai_grc(begg:,1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -608,6 +612,20 @@ subroutine import_fields( gcomp, bounds, glc_present, rof_prognostic, & wateratm2lndbulk_inst%volrmch_grc(:) = 0._r8 end if + if (fldchk(importState, Sr_tdepth)) then + call state_getimport_1d(importState, Sr_tdepth, wateratm2lndbulk_inst%tdepth_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + wateratm2lndbulk_inst%tdepth_grc(:) = 0._r8 + end if + + if (fldchk(importState, Sr_tdepth_max)) then + call state_getimport_1d(importState, Sr_tdepth_max, wateratm2lndbulk_inst%tdepthmax_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + wateratm2lndbulk_inst%tdepthmax_grc(:) = 0._r8 + end if + !-------------------------- ! Derived quantities for required fields ! and corresponding error checks @@ -891,6 +909,10 @@ subroutine export_fields( gcomp, bounds, glc_present, rof_prognostic, & do g = begg, endg data1d(g) = waterlnd2atmbulk_inst%qflx_rofliq_qsub_grc(g) + & waterlnd2atmbulk_inst%qflx_rofliq_drain_perched_grc(g) + if (use_hillslope_routing) then + data1d(g) = data1d(g) + & + waterlnd2atmbulk_inst%qflx_rofliq_stream_grc(g) + endif end do call state_setexport_1d(exportState, Flrl_rofsub, data1d(begg:), init_spval=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/cpl/utils/lnd_import_export_utils.F90 b/src/cpl/utils/lnd_import_export_utils.F90 index 4b7941da5b..1b40cb0e6c 100644 --- a/src/cpl/utils/lnd_import_export_utils.F90 +++ b/src/cpl/utils/lnd_import_export_utils.F90 @@ -76,8 +76,11 @@ subroutine derive_quantities( bounds, atm2lnd_inst, wateratm2lndbulk_inst, & atm2lnd_inst%forc_wind_grc(g) = sqrt(atm2lnd_inst%forc_u_grc(g)**2 + atm2lnd_inst%forc_v_grc(g)**2) - atm2lnd_inst%forc_solar_grc(g) = atm2lnd_inst%forc_solad_grc(g,1) + atm2lnd_inst%forc_solai_grc(g,1) + & - atm2lnd_inst%forc_solad_grc(g,2) + atm2lnd_inst%forc_solai_grc(g,2) + atm2lnd_inst%forc_solar_not_downscaled_grc(g) = & + atm2lnd_inst%forc_solad_not_downscaled_grc(g,1) & + + atm2lnd_inst%forc_solai_grc(g,1) & + + atm2lnd_inst%forc_solad_not_downscaled_grc(g,2) & + + atm2lnd_inst%forc_solai_grc(g,2) wateratm2lndbulk_inst%forc_rain_not_downscaled_grc(g) = forc_rainc(g) + forc_rainl(g) wateratm2lndbulk_inst%forc_snow_not_downscaled_grc(g) = forc_snowc(g) + forc_snowl(g) @@ -118,8 +121,8 @@ subroutine check_for_errors( bounds, atm2lnd_inst, wateratm2lndbulk_inst ) call shr_sys_abort( subname//& ' ERROR: Longwave down sent from the atmosphere model is negative or zero' ) end if - if ( (atm2lnd_inst%forc_solad_grc(g,1) < 0.0_r8) .or. & - (atm2lnd_inst%forc_solad_grc(g,2) < 0.0_r8) .or. & + if ( (atm2lnd_inst%forc_solad_not_downscaled_grc(g,1) < 0.0_r8) .or. & + (atm2lnd_inst%forc_solad_not_downscaled_grc(g,2) < 0.0_r8) .or. & (atm2lnd_inst%forc_solai_grc(g,1) < 0.0_r8) .or. & (atm2lnd_inst%forc_solai_grc(g,2) < 0.0_r8) ) then call shr_sys_abort( subname//& @@ -141,6 +144,7 @@ end subroutine check_for_errors !============================================================================= subroutine check_for_nans(array, fname, begg, direction) + use GridcellType , only : grc ! input/output variables real(r8) , intent(in) :: array(:) @@ -159,7 +163,7 @@ subroutine check_for_nans(array, fname, begg, direction) write(iulog,*) 'Which are NaNs = ', isnan(array) do i = 1, size(array) if (isnan(array(i))) then - write(iulog,*) "NaN found in field ", trim(fname), ' at gridcell index ',begg+i-1 + write(iulog,*) "NaN found in field ", trim(fname), ' at gridcell index/lon/lat: ',begg+i-1,grc%londeg(begg+i-1),grc%latdeg(begg+i-1) end if end do call shr_sys_abort(' ERROR: One or more of the CTSM cap '//direction//' fields are NaN ' ) diff --git a/src/main/ColumnType.F90 b/src/main/ColumnType.F90 index 5f57b3ed23..ab7ee8e261 100644 --- a/src/main/ColumnType.F90 +++ b/src/main/ColumnType.F90 @@ -68,8 +68,20 @@ module ColumnType real(r8), pointer :: z_lake (:,:) ! layer depth for lake (m) real(r8), pointer :: lakedepth (:) ! variable lake depth (m) integer , pointer :: nbedrock (:) ! variable depth to bedrock index + ! hillslope hydrology variables + integer, pointer :: col_ndx (:) ! column index of column (hillslope hydrology) + integer, pointer :: colu (:) ! column index of uphill column (hillslope hydrology) + integer, pointer :: cold (:) ! column index of downhill column (hillslope hydrology) + integer, pointer :: hillslope_ndx (:) ! hillslope identifier + real(r8), pointer :: hill_elev (:) ! mean elevation of column relative to stream channel (m) + real(r8), pointer :: hill_slope (:) ! mean along-hill slope (m/m) + real(r8), pointer :: hill_area (:) ! mean surface area (m2) + real(r8), pointer :: hill_width (:) ! across-hill width of bottom boundary of column (m) + real(r8), pointer :: hill_distance (:) ! along-hill distance of column from bottom of hillslope (m) + real(r8), pointer :: hill_aspect (:) ! azimuth angle of column wrt to north, positive to east (radians) ! other column characteristics + logical , pointer :: is_hillslope_column(:) ! true if this column is a hillslope element logical , pointer :: hydrologically_active(:) ! true if this column is a hydrologically active type logical , pointer :: urbpoi (:) ! true=>urban point @@ -130,13 +142,22 @@ subroutine Init(this, begc, endc) allocate(this%lakedepth (begc:endc)) ; this%lakedepth (:) = spval allocate(this%dz_lake (begc:endc,nlevlak)) ; this%dz_lake (:,:) = nan allocate(this%z_lake (begc:endc,nlevlak)) ; this%z_lake (:,:) = nan - + allocate(this%col_ndx (begc:endc)) ; this%col_ndx(:) = ispval + allocate(this%colu (begc:endc)) ; this%colu (:) = ispval + allocate(this%cold (begc:endc)) ; this%cold (:) = ispval + allocate(this%hillslope_ndx(begc:endc)) ; this%hillslope_ndx (:) = ispval + allocate(this%hill_elev(begc:endc)) ; this%hill_elev (:) = spval + allocate(this%hill_slope(begc:endc)) ; this%hill_slope (:) = spval + allocate(this%hill_area(begc:endc)) ; this%hill_area (:) = spval + allocate(this%hill_width(begc:endc)) ; this%hill_width (:) = spval + allocate(this%hill_distance(begc:endc)) ; this%hill_distance (:) = spval + allocate(this%hill_aspect(begc:endc)) ; this%hill_aspect (:) = spval allocate(this%nbedrock (begc:endc)) ; this%nbedrock (:) = ispval allocate(this%levgrnd_class(begc:endc,nlevmaxurbgrnd)) ; this%levgrnd_class(:,:) = ispval allocate(this%micro_sigma (begc:endc)) ; this%micro_sigma (:) = nan allocate(this%topo_slope (begc:endc)) ; this%topo_slope (:) = nan allocate(this%topo_std (begc:endc)) ; this%topo_std (:) = nan - + allocate(this%is_hillslope_column(begc:endc)) ; this%is_hillslope_column(:) = .false. allocate(this%hydrologically_active(begc:endc)) ; this%hydrologically_active(:) = .false. allocate(this%urbpoi (begc:endc)) ; this%urbpoi (:) = .false. @@ -174,9 +195,19 @@ subroutine Clean(this) deallocate(this%topo_std ) deallocate(this%nbedrock ) deallocate(this%levgrnd_class) + deallocate(this%is_hillslope_column) deallocate(this%hydrologically_active) - deallocate(this%urbpoi) - + deallocate(this%col_ndx ) + deallocate(this%colu ) + deallocate(this%cold ) + deallocate(this%hillslope_ndx) + deallocate(this%hill_elev ) + deallocate(this%hill_slope ) + deallocate(this%hill_area ) + deallocate(this%hill_width ) + deallocate(this%hill_distance) + deallocate(this%hill_aspect ) + deallocate(this%urbpoi ) end subroutine Clean !----------------------------------------------------------------------- diff --git a/src/main/LandunitType.F90 b/src/main/LandunitType.F90 index 22770d2334..3a5c68c4f3 100644 --- a/src/main/LandunitType.F90 +++ b/src/main/LandunitType.F90 @@ -32,6 +32,7 @@ module LandunitType integer , pointer :: coli (:) ! beginning column index per landunit integer , pointer :: colf (:) ! ending column index for each landunit integer , pointer :: ncolumns (:) ! number of columns for each landunit + integer , pointer :: nhillslopes (:) ! number of hillslopes for each landunit integer , pointer :: patchi (:) ! beginning patch index for each landunit integer , pointer :: patchf (:) ! ending patch index for each landunit integer , pointer :: npatches (:) ! number of patches for each landunit @@ -52,6 +53,13 @@ module LandunitType real(r8), pointer :: z_0_town (:) ! urban landunit momentum roughness length (m) real(r8), pointer :: z_d_town (:) ! urban landunit displacement height (m) + ! hillslope variables + real(r8), pointer :: stream_channel_depth (:) ! stream channel bankfull depth (m) + real(r8), pointer :: stream_channel_width (:) ! stream channel bankfull width (m) + real(r8), pointer :: stream_channel_length (:) ! stream channel length (m) + real(r8), pointer :: stream_channel_slope (:) ! stream channel slope (m/m) + real(r8), pointer :: stream_channel_number (:) ! number of channels in landunit + contains procedure, public :: Init ! Allocate and initialize @@ -82,6 +90,7 @@ subroutine Init(this, begl, endl) allocate(this%coli (begl:endl)); this%coli (:) = ispval allocate(this%colf (begl:endl)); this%colf (:) = ispval allocate(this%ncolumns (begl:endl)); this%ncolumns (:) = ispval + allocate(this%nhillslopes (begl:endl)); this%nhillslopes(:) = ispval allocate(this%patchi (begl:endl)); this%patchi (:) = ispval allocate(this%patchf (begl:endl)); this%patchf (:) = ispval allocate(this%npatches (begl:endl)); this%npatches (:) = ispval @@ -102,6 +111,13 @@ subroutine Init(this, begl, endl) allocate(this%z_0_town (begl:endl)); this%z_0_town (:) = nan allocate(this%z_d_town (begl:endl)); this%z_d_town (:) = nan + ! Hillslope variables initialized in HillslopeHydrologyMod + allocate(this%stream_channel_depth(begl:endl)); this%stream_channel_depth (:) = nan + allocate(this%stream_channel_width(begl:endl)); this%stream_channel_width (:) = nan + allocate(this%stream_channel_length(begl:endl)); this%stream_channel_length (:) = nan + allocate(this%stream_channel_slope(begl:endl)); this%stream_channel_slope (:) = nan + allocate(this%stream_channel_number(begl:endl)); this%stream_channel_number (:) = nan + end subroutine Init !------------------------------------------------------------------------ @@ -119,6 +135,7 @@ subroutine Clean(this) deallocate(this%coli ) deallocate(this%colf ) deallocate(this%ncolumns ) + deallocate(this%nhillslopes ) deallocate(this%patchi ) deallocate(this%patchf ) deallocate(this%npatches ) @@ -134,7 +151,11 @@ subroutine Clean(this) deallocate(this%wtlunit_roof ) deallocate(this%z_0_town ) deallocate(this%z_d_town ) - + deallocate(this%stream_channel_depth) + deallocate(this%stream_channel_width) + deallocate(this%stream_channel_length) + deallocate(this%stream_channel_slope) + deallocate(this%stream_channel_number) end subroutine Clean end module LandunitType diff --git a/src/main/TopoMod.F90 b/src/main/TopoMod.F90 index e14762cc21..b081c77482 100644 --- a/src/main/TopoMod.F90 +++ b/src/main/TopoMod.F90 @@ -13,8 +13,9 @@ module TopoMod use LandunitType , only : lun use glc2lndMod , only : glc2lnd_type use glcBehaviorMod , only : glc_behavior_type - use landunit_varcon, only : istice + use landunit_varcon, only : istice, istsoil use filterColMod , only : filter_col_type, col_filter_from_logical_array_active_only + use clm_varctl , only : use_hillslope, downscale_hillslope_meteorology ! ! !PUBLIC TYPES: implicit none @@ -139,8 +140,14 @@ subroutine InitCold(this, bounds) ! For other landunits, arbitrarily initialize topo_col to 0 m; for landunits ! where this matters, this will get overwritten in the run loop by values sent ! from CISM - this%topo_col(c) = 0._r8 - this%needs_downscaling_col(c) = .false. + if (col%is_hillslope_column(c) .and. downscale_hillslope_meteorology) then + this%topo_col(c) = col%hill_elev(c) + this%needs_downscaling_col(c) = .true. + else + this%topo_col(c) = 0._r8 + this%needs_downscaling_col(c) = .false. + endif + end if end do @@ -218,7 +225,9 @@ subroutine UpdateTopo(this, bounds, num_icec, filter_icec, & ! ! !LOCAL VARIABLES: integer :: begc, endc - integer :: c, g + integer :: c, l, g + real(r8), allocatable :: mean_hillslope_elevation(:) + real(r8):: mhe_norm character(len=*), parameter :: subname = 'UpdateTopo' !----------------------------------------------------------------------- @@ -240,18 +249,48 @@ subroutine UpdateTopo(this, bounds, num_icec, filter_icec, & this%topo_col(begc:endc), & this%needs_downscaling_col(begc:endc)) - ! For any point that isn't downscaled, set its topo value to the atmosphere's - ! topographic height. This shouldn't matter, but is useful if topo_col is written to - ! the history file. - ! + ! calculate area-weighted mean hillslope elevation on each landunit + if (use_hillslope) then + allocate(mean_hillslope_elevation(bounds%begl:bounds%endl)) + mean_hillslope_elevation(:) = 0._r8 + do l = bounds%begl, bounds%endl + mhe_norm = 0._r8 + do c = lun%coli(l), lun%colf(l) + if (col%is_hillslope_column(c)) then + mean_hillslope_elevation(l) = mean_hillslope_elevation(l) & + + col%hill_elev(c)*col%hill_area(c) + mhe_norm = mhe_norm + col%hill_area(c) + endif + enddo + if (mhe_norm > 0) then + mean_hillslope_elevation(l) = mean_hillslope_elevation(l)/mhe_norm + endif + enddo + endif + ! This could operate over a filter like 'allc' in order to just operate over active ! points, but I'm not sure that would speed things up much, and would require passing ! in this additional filter. + do c = bounds%begc, bounds%endc if (.not. this%needs_downscaling_col(c)) then + ! For any point that isn't already set to be downscaled, set its topo value to the + ! atmosphere's topographic height. This is important for the hillslope block + ! below. For non-hillslope columns, this shouldn't matter, but is useful if + ! topo_col is written to the history file. g = col%gridcell(c) this%topo_col(c) = atm_topo(g) end if + ! If needs_downscaling_col was already set, then that implies + ! that topo_col was previously set by update_glc2lnd_topo. + ! In that case, topo_col should be used as a starting point, + ! rather than the atmosphere's topo value. + if (col%is_hillslope_column(c) .and. downscale_hillslope_meteorology) then + l = col%landunit(c) + this%topo_col(c) = this%topo_col(c) & + + (col%hill_elev(c) - mean_hillslope_elevation(l)) + this%needs_downscaling_col(c) = .true. + endif end do call glc_behavior%update_glc_classes(bounds, this%topo_col(begc:endc)) diff --git a/src/main/atm2lndMod.F90 b/src/main/atm2lndMod.F90 index 11e05f1496..5da4ff6333 100644 --- a/src/main/atm2lndMod.F90 +++ b/src/main/atm2lndMod.F90 @@ -18,12 +18,14 @@ module atm2lndMod use decompMod , only : bounds_type, subgrid_level_gridcell, subgrid_level_column use atm2lndType , only : atm2lnd_type use TopoMod , only : topo_type + use SurfaceAlbedoType, only : surfalb_type use filterColMod , only : filter_col_type use LandunitType , only : lun use ColumnType , only : col use landunit_varcon, only : istice use WaterType , only : water_type use Wateratm2lndBulkType, only : wateratm2lndbulk_type + ! ! !PUBLIC TYPES: implicit none @@ -46,6 +48,9 @@ module atm2lndMod private :: build_normalization ! Compute normalization factors so that downscaled fields are conservative private :: check_downscale_consistency ! Check consistency of downscaling + private :: downscale_hillslope_solar ! Downscale incoming direct solar radiation based on local slope and aspect. + private :: downscale_hillslope_precipitation ! Downscale precipitation based on local topographic height. + character(len=*), parameter, private :: sourcefile = & __FILE__ !----------------------------------------------------------------------- @@ -91,7 +96,7 @@ end subroutine set_atm2lnd_water_tracers !----------------------------------------------------------------------- subroutine downscale_forcings(bounds, & - topo_inst, atm2lnd_inst, wateratm2lndbulk_inst, eflx_sh_precip_conversion) + topo_inst, atm2lnd_inst, surfalb_inst, wateratm2lndbulk_inst, eflx_sh_precip_conversion) ! ! !DESCRIPTION: ! Downscale atmospheric forcing fields from gridcell to column. @@ -111,12 +116,14 @@ subroutine downscale_forcings(bounds, & ! ! !USES: use clm_varcon , only : rair, cpair, grav + use clm_varctl , only : use_hillslope,downscale_hillslope_meteorology use QsatMod , only : Qsat ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds class(topo_type) , intent(in) :: topo_inst type(atm2lnd_type) , intent(inout) :: atm2lnd_inst + class(surfalb_type) , intent(in) :: surfalb_inst type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst real(r8) , intent(out) :: eflx_sh_precip_conversion(bounds%begc:) ! sensible heat flux from precipitation conversion (W/m**2) [+ to atm] ! @@ -143,6 +150,8 @@ subroutine downscale_forcings(bounds, & ! Gridcell-level metadata: forc_topo_g => atm2lnd_inst%forc_topo_grc , & ! Input: [real(r8) (:)] atmospheric surface height (m) + forc_rain_g => wateratm2lndbulk_inst%forc_rain_not_downscaled_grc , & ! Input: [real(r8) (:)] rain rate [mm/s] + forc_snow_g => wateratm2lndbulk_inst%forc_snow_not_downscaled_grc , & ! Input: [real(r8) (:)] snow rate [mm/s] ! Column-level metadata: topo_c => topo_inst%topo_col , & ! Input: [real(r8) (:)] column surface height (m) @@ -153,13 +162,19 @@ subroutine downscale_forcings(bounds, & forc_q_g => wateratm2lndbulk_inst%forc_q_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric specific humidity (kg/kg) forc_pbot_g => atm2lnd_inst%forc_pbot_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric pressure (Pa) forc_rho_g => atm2lnd_inst%forc_rho_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric density (kg/m**3) - + forc_solad_g => atm2lnd_inst%forc_solad_not_downscaled_grc , & ! Input: [real(r8) (:)] gridcell direct incoming solar radiation + forc_solar_g => atm2lnd_inst%forc_solar_not_downscaled_grc, & ! Input: [real(r8) (:)] gridcell direct incoming solar radiation + ! Column-level downscaled fields: + forc_rain_c => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Output: [real(r8) (:)] rain rate [mm/s] + forc_snow_c => wateratm2lndbulk_inst%forc_snow_downscaled_col , & ! Output: [real(r8) (:)] snow rate [mm/s] + forc_q_c => wateratm2lndbulk_inst%forc_q_downscaled_col , & ! Output: [real(r8) (:)] atmospheric specific humidity (kg/kg) forc_t_c => atm2lnd_inst%forc_t_downscaled_col , & ! Output: [real(r8) (:)] atmospheric temperature (Kelvin) forc_th_c => atm2lnd_inst%forc_th_downscaled_col , & ! Output: [real(r8) (:)] atmospheric potential temperature (Kelvin) - forc_q_c => wateratm2lndbulk_inst%forc_q_downscaled_col , & ! Output: [real(r8) (:)] atmospheric specific humidity (kg/kg) forc_pbot_c => atm2lnd_inst%forc_pbot_downscaled_col , & ! Output: [real(r8) (:)] atmospheric pressure (Pa) - forc_rho_c => atm2lnd_inst%forc_rho_downscaled_col & ! Output: [real(r8) (:)] atmospheric density (kg/m**3) + forc_rho_c => atm2lnd_inst%forc_rho_downscaled_col , & ! Output: [real(r8) (:)] atmospheric density (kg/m**3) + forc_solad_c => atm2lnd_inst%forc_solad_downscaled_col , & ! Output: [real(r8) (:)] column direct incoming solar radiation + forc_solar_c => atm2lnd_inst%forc_solar_downscaled_col & ! Output: [real(r8) (:)] column total incoming solar radiation ) ! Initialize column forcing (needs to be done for ALL active columns) @@ -167,11 +182,15 @@ subroutine downscale_forcings(bounds, & if (col%active(c)) then g = col%gridcell(c) + forc_rain_c(c) = forc_rain_g(g) + forc_snow_c(c) = forc_snow_g(g) forc_t_c(c) = forc_t_g(g) forc_th_c(c) = forc_th_g(g) forc_q_c(c) = forc_q_g(g) forc_pbot_c(c) = forc_pbot_g(g) forc_rho_c(c) = forc_rho_g(g) + forc_solar_c(c) = forc_solar_g(g) + forc_solad_c(c,1:numrad) = forc_solad_g(g,1:numrad) end if end do @@ -247,6 +266,12 @@ subroutine downscale_forcings(bounds, & end do + ! adjust hillslope precpitation before repartitioning rain/snow + if (use_hillslope .and. downscale_hillslope_meteorology) then + call downscale_hillslope_solar(bounds, atm2lnd_inst, surfalb_inst) + call downscale_hillslope_precipitation(bounds, topo_inst, atm2lnd_inst, wateratm2lndbulk_inst) + endif + call partition_precip(bounds, atm2lnd_inst, wateratm2lndbulk_inst, & eflx_sh_precip_conversion(bounds%begc:bounds%endc)) @@ -312,10 +337,6 @@ subroutine partition_precip(bounds, atm2lnd_inst, wateratm2lndbulk_inst, eflx_sh SHR_ASSERT_ALL_FL((ubound(eflx_sh_precip_conversion) == (/bounds%endc/)), sourcefile, __LINE__) associate(& - ! Gridcell-level non-downscaled fields: - forc_rain_g => wateratm2lndbulk_inst%forc_rain_not_downscaled_grc , & ! Input: [real(r8) (:)] rain rate [mm/s] - forc_snow_g => wateratm2lndbulk_inst%forc_snow_not_downscaled_grc , & ! Input: [real(r8) (:)] snow rate [mm/s] - ! Column-level downscaled fields: forc_t_c => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:)] atmospheric temperature (Kelvin) forc_rain_c => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Output: [real(r8) (:)] rain rate [mm/s] @@ -328,8 +349,6 @@ subroutine partition_precip(bounds, atm2lnd_inst, wateratm2lndbulk_inst, eflx_sh do c = bounds%begc,bounds%endc if (col%active(c)) then g = col%gridcell(c) - forc_rain_c(c) = forc_rain_g(g) - forc_snow_c(c) = forc_snow_g(g) rain_to_snow_conversion_c(c) = 0._r8 snow_to_rain_conversion_c(c) = 0._r8 eflx_sh_precip_conversion(c) = 0._r8 @@ -719,4 +738,250 @@ subroutine check_downscale_consistency(bounds, atm2lnd_inst, wateratm2lndbulk_in end subroutine check_downscale_consistency + subroutine downscale_hillslope_solar(bounds, atm2lnd_inst, surfalb_inst) + ! + ! !DESCRIPTION: + ! Downscale incoming direct solar radiation based on local slope and aspect. + ! + ! This is currently applied over columns + ! + ! USES + use clm_varpar , only : numrad + + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(surfalb_type) , intent(in) :: surfalb_inst + type(atm2lnd_type) , intent(inout) :: atm2lnd_inst + ! + ! !LOCAL VARIABLES: + integer :: c,l,g,n ! indices + real(r8) :: norm(numrad) + real(r8) :: sum_solar(bounds%begg:bounds%endg,numrad) + real(r8) :: sum_wtgcell(bounds%begg:bounds%endg) + real(r8) :: illum_frac(bounds%begg:bounds%endg) + real(r8), parameter :: illumination_threshold = 0.05 + logical :: checkConservation = .true. + + character(len=*), parameter :: subname = 'downscale_hillslope_solar' + !----------------------------------------------------------------------- + + associate(& + ! Gridcell-level fields: + forc_solai_grc => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:)] gridcell indirect incoming solar radiation + forc_solad_grc => atm2lnd_inst%forc_solad_not_downscaled_grc , & ! Input: [real(r8) (:)] gridcell direct incoming solar radiation + coszen_grc => surfalb_inst%coszen_grc , & ! Input: [real(r8) (:)] cosine of solar zenith angle + + ! Column-level fields: + coszen_col => surfalb_inst%coszen_col , & ! Input: [real(r8) (:)] cosine of solar zenith angle + forc_solar_col => atm2lnd_inst%forc_solar_downscaled_col , & ! Output: [real(r8) (:)] column total incoming solar radiation + forc_solad_col => atm2lnd_inst%forc_solad_downscaled_col & ! Output: [real(r8) (:)] column direct incoming solar radiation + ) + + ! Initialize column forcing + sum_solar(bounds%begg:bounds%endg,1:numrad) = 0._r8 + sum_wtgcell(bounds%begg:bounds%endg) = 0._r8 + illum_frac(bounds%begg:bounds%endg) = 0._r8 + do c = bounds%begc,bounds%endc + if (col%is_hillslope_column(c) .and. col%active(c)) then + g = col%gridcell(c) + if (coszen_grc(g) > 0._r8) then + forc_solad_col(c,1:numrad) = forc_solad_grc(g,1:numrad)*(coszen_col(c)/coszen_grc(g)) + if (coszen_col(c) > 0._r8) then + illum_frac(g) = illum_frac(g) + col%wtgcell(c) + endif + endif + + sum_solar(g,1:numrad) = sum_solar(g,1:numrad) + col%wtgcell(c)*forc_solad_col(c,1:numrad) + sum_wtgcell(g) = sum_wtgcell(g) + col%wtgcell(c) + end if + end do + + ! Calculate illuminated fraction of gridcell + do g = bounds%begg,bounds%endg + if (sum_wtgcell(g) > 0._r8) then + illum_frac(g) = illum_frac(g)/sum_wtgcell(g) + endif + enddo + + ! Normalize column level solar + do c = bounds%begc,bounds%endc + if (col%is_hillslope_column(c) .and. col%active(c)) then + g = col%gridcell(c) + do n = 1,numrad + ! absorbed energy is solar flux x area landunit (sum_wtgcell) + if(sum_solar(g,n) > 0._r8 .and. illum_frac(g) > illumination_threshold) then + norm(n) = sum_wtgcell(g)*forc_solad_grc(g,n)/sum_solar(g,n) + forc_solad_col(c,n) = forc_solad_col(c,n)*norm(n) + else + forc_solad_col(c,n) = forc_solad_grc(g,n) + endif + enddo + forc_solar_col(c) = sum(forc_solad_col(c,1:numrad))+sum(forc_solai_grc(g,1:numrad)) + end if + + end do + + ! check conservation + if(checkConservation) then + sum_solar(bounds%begg:bounds%endg,1:numrad) = 0._r8 + sum_wtgcell(bounds%begg:bounds%endg) = 0._r8 + ! Calculate normalization (area-weighted solar flux) + do c = bounds%begc,bounds%endc + if (col%is_hillslope_column(c) .and. col%active(c)) then + g = col%gridcell(c) + do n = 1,numrad + sum_solar(g,n) = sum_solar(g,n) + col%wtgcell(c)*forc_solad_col(c,n) + enddo + sum_wtgcell(g) = sum_wtgcell(g) + col%wtgcell(c) + end if + end do + do g = bounds%begg,bounds%endg + do n = 1,numrad + if(abs(sum_solar(g,n) - sum_wtgcell(g)*forc_solad_grc(g,n)) > 1.e-6) then + write(iulog,*) 'downscaled solar not conserved', g, n, sum_solar(g,n), sum_wtgcell(g)*forc_solad_grc(g,n) + call endrun(subgrid_index=g, subgrid_level=subgrid_level_gridcell, & + msg=' ERROR: Energy conservation error downscaling solar'//& + errMsg(sourcefile, __LINE__)) + endif + enddo + enddo + endif + + + end associate + + end subroutine downscale_hillslope_solar + + !----------------------------------------------------------------------- + subroutine downscale_hillslope_precipitation(bounds, & + topo_inst, atm2lnd_inst, wateratm2lndbulk_inst) + ! + ! !DESCRIPTION: + ! Downscale precipitation from gridcell to column. + ! + ! Downscaling is done based on the difference between each CLM column's elevation and + ! the atmosphere's surface elevation (which is the elevation at which the atmospheric + ! forcings are valid). + ! + ! !USES: + use clm_varcon , only : rair, cpair, grav + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + class(topo_type) , intent(in) :: topo_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst + ! + ! !LOCAL VARIABLES: + integer :: g, l, c, fc ! indices + + ! temporaries for topo downscaling + real(r8) :: precip_anom, topo_anom + real(r8) :: norm_rain(bounds%begg:bounds%endg) + real(r8) :: norm_snow(bounds%begg:bounds%endg) + real(r8) :: sum_wt(bounds%begg:bounds%endg) + real(r8), parameter :: rain_scalar = 1.5e-3_r8 ! (1/m) + real(r8), parameter :: snow_scalar = 1.5e-3_r8 ! (1/m) + logical :: checkConservation = .true. + character(len=*), parameter :: subname = 'downscale_hillslope_precipitation' + !----------------------------------------------------------------------- + + associate(& + ! Gridcell-level metadata: + forc_topo_g => atm2lnd_inst%forc_topo_grc , & ! Input: [real(r8) (:)] atmospheric surface height (m) + forc_rain_g => wateratm2lndbulk_inst%forc_rain_not_downscaled_grc , & ! Input: [real(r8) (:)] rain rate [mm/s] + forc_snow_g => wateratm2lndbulk_inst%forc_snow_not_downscaled_grc , & ! Input: [real(r8) (:)] snow rate [mm/s] + ! Column-level metadata: + topo_c => topo_inst%topo_col , & ! Input: [real(r8) (:)] column surface height (m) + + ! Column-level downscaled fields: + forc_rain_c => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Output: [real(r8) (:)] rain rate [mm/s] + forc_snow_c => wateratm2lndbulk_inst%forc_snow_downscaled_col & ! Output: [real(r8) (:)] snow rate [mm/s] + ) + + ! Redistribute precipitation based on departure + ! of column elevation from mean elevation + + do c = bounds%begc,bounds%endc + g = col%gridcell(c) + if (col%is_hillslope_column(c) .and. col%active(c)) then + + ! spatially uniform normalization, but separate rain/snow + topo_anom = max(-1._r8,(topo_c(c) - forc_topo_g(g))*rain_scalar) ! rain + precip_anom = forc_rain_g(g) * topo_anom + forc_rain_c(c) = forc_rain_c(c) + precip_anom + + topo_anom = max(-1._r8,(topo_c(c) - forc_topo_g(g))*snow_scalar) ! snow + precip_anom = forc_snow_g(g) * topo_anom + forc_snow_c(c) = forc_snow_c(c) + precip_anom + + end if + end do + + ! Initialize arrays of total landunit precipitation + norm_rain(bounds%begg:bounds%endg) = 0._r8 + norm_snow(bounds%begg:bounds%endg) = 0._r8 + sum_wt(bounds%begg:bounds%endg) = 0._r8 + ! Calculate normalization (area-weighted average precipitation) + do c = bounds%begc,bounds%endc + g = col%gridcell(c) + if (col%is_hillslope_column(c) .and. col%active(c)) then + norm_rain(g) = norm_rain(g) + col%wtgcell(c)*forc_rain_c(c) + norm_snow(g) = norm_snow(g) + col%wtgcell(c)*forc_snow_c(c) + sum_wt(g) = sum_wt(g) + col%wtgcell(c) + end if + end do + do g = bounds%begg,bounds%endg + if(sum_wt(g) > 0._r8) then + norm_rain(g) = norm_rain(g) / sum_wt(g) + norm_snow(g) = norm_snow(g) / sum_wt(g) + endif + enddo + + ! Normalize column precipitation to conserve gridcell average + do c = bounds%begc,bounds%endc + g = col%gridcell(c) + if (col%is_hillslope_column(c) .and. col%active(c)) then + if (norm_rain(g) > 0._r8) then + forc_rain_c(c) = forc_rain_c(c) * forc_rain_g(g) / norm_rain(g) + else + forc_rain_c(c) = forc_rain_g(g) + endif + if (norm_snow(g) > 0._r8) then + forc_snow_c(c) = forc_snow_c(c) * forc_snow_g(g) / norm_snow(g) + else + forc_snow_c(c) = forc_snow_g(g) + endif + end if + end do + + ! check conservation + if(checkConservation) then + norm_rain(bounds%begg:bounds%endg) = 0._r8 + norm_snow(bounds%begg:bounds%endg) = 0._r8 + sum_wt(bounds%begg:bounds%endg) = 0._r8 + ! Calculate normalization (area-weighted average precipitation) + do c = bounds%begc,bounds%endc + g = col%gridcell(c) + if (col%is_hillslope_column(c) .and. col%active(c)) then + norm_rain(g) = norm_rain(g) + col%wtgcell(c)*forc_rain_c(c) + norm_snow(g) = norm_snow(g) + col%wtgcell(c)*forc_snow_c(c) + sum_wt(g) = sum_wt(g) + col%wtgcell(c) + end if + end do + do g = bounds%begg,bounds%endg + if(abs(norm_rain(g) - sum_wt(g)*forc_rain_g(g)) > 1.e-6) then + write(iulog,*) 'rain not conserved', g, norm_rain(g), sum_wt(g)*forc_rain_g(g) + endif + if(abs(norm_snow(g) - sum_wt(g)*forc_snow_g(g)) > 1.e-6) then + write(iulog,*) 'snow not conserved', g, norm_snow(g), sum_wt(g)*forc_snow_g(g) + endif + enddo + endif + + end associate + + end subroutine downscale_hillslope_precipitation + + end module atm2lndMod diff --git a/src/main/atm2lndType.F90 b/src/main/atm2lndType.F90 index 53013caf24..b99e0c8ba1 100644 --- a/src/main/atm2lndType.F90 +++ b/src/main/atm2lndType.F90 @@ -80,9 +80,10 @@ module atm2lndType real(r8), pointer :: forc_vp_grc (:) => null() ! atmospheric vapor pressure (Pa) real(r8), pointer :: forc_pco2_grc (:) => null() ! CO2 partial pressure (Pa) real(r8), pointer :: forc_pco2_240_patch (:) => null() ! 10-day mean CO2 partial pressure (Pa) - real(r8), pointer :: forc_solad_grc (:,:) => null() ! direct beam radiation (numrad) (vis=forc_sols , nir=forc_soll ) + real(r8), pointer :: forc_solad_not_downscaled_grc (:,:) => null() ! direct beam radiation (numrad) (vis=forc_sols , nir=forc_soll ) real(r8), pointer :: forc_solai_grc (:,:) => null() ! diffuse radiation (numrad) (vis=forc_solsd, nir=forc_solld) - real(r8), pointer :: forc_solar_grc (:) => null() ! incident solar radiation + real(r8), pointer :: forc_solar_not_downscaled_grc (:) => null() ! incident solar radiation + real(r8), pointer :: forc_solar_downscaled_col (:) => null() ! incident solar radiation real(r8), pointer :: forc_ndep_grc (:) => null() ! nitrogen deposition rate (gN/m2/s) real(r8), pointer :: forc_pc13o2_grc (:) => null() ! C13O2 partial pressure (Pa) real(r8), pointer :: forc_po2_grc (:) => null() ! O2 partial pressure (Pa) @@ -104,7 +105,7 @@ module atm2lndType real(r8), pointer :: forc_pbot_downscaled_col (:) => null() ! downscaled atm pressure (Pa) real(r8), pointer :: forc_rho_downscaled_col (:) => null() ! downscaled atm density (kg/m**3) real(r8), pointer :: forc_lwrad_downscaled_col (:) => null() ! downscaled atm downwrd IR longwave radiation (W/m**2) - + real(r8), pointer :: forc_solad_downscaled_col (:,:) => null() ! direct beam radiation (numrad) (vis=forc_sols , nir=forc_soll ) ! time averaged quantities real(r8) , pointer :: fsd24_patch (:) => null() ! patch 24hr average of direct beam radiation @@ -475,9 +476,9 @@ subroutine InitAllocate(this, bounds) allocate(this%forc_hgt_q_grc (begg:endg)) ; this%forc_hgt_q_grc (:) = ival allocate(this%forc_vp_grc (begg:endg)) ; this%forc_vp_grc (:) = ival allocate(this%forc_pco2_grc (begg:endg)) ; this%forc_pco2_grc (:) = ival - allocate(this%forc_solad_grc (begg:endg,numrad)) ; this%forc_solad_grc (:,:) = ival + allocate(this%forc_solad_not_downscaled_grc (begg:endg,numrad)) ; this%forc_solad_not_downscaled_grc (:,:) = ival allocate(this%forc_solai_grc (begg:endg,numrad)) ; this%forc_solai_grc (:,:) = ival - allocate(this%forc_solar_grc (begg:endg)) ; this%forc_solar_grc (:) = ival + allocate(this%forc_solar_not_downscaled_grc (begg:endg)) ; this%forc_solar_not_downscaled_grc (:) = ival allocate(this%forc_ndep_grc (begg:endg)) ; this%forc_ndep_grc (:) = ival allocate(this%forc_pc13o2_grc (begg:endg)) ; this%forc_pc13o2_grc (:) = ival allocate(this%forc_po2_grc (begg:endg)) ; this%forc_po2_grc (:) = ival @@ -503,6 +504,8 @@ subroutine InitAllocate(this, bounds) allocate(this%forc_th_downscaled_col (begc:endc)) ; this%forc_th_downscaled_col (:) = ival allocate(this%forc_rho_downscaled_col (begc:endc)) ; this%forc_rho_downscaled_col (:) = ival allocate(this%forc_lwrad_downscaled_col (begc:endc)) ; this%forc_lwrad_downscaled_col (:) = ival + allocate(this%forc_solad_downscaled_col (begc:endc,numrad)) ; this%forc_solad_downscaled_col (:,:) = ival + allocate(this%forc_solar_downscaled_col (begc:endc)) ; this%forc_solar_downscaled_col (:) = ival allocate(this%fsd24_patch (begp:endp)) ; this%fsd24_patch (:) = nan allocate(this%fsd240_patch (begp:endp)) ; this%fsd240_patch (:) = nan @@ -555,24 +558,25 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='atmospheric surface height', & ptr_lnd=this%forc_topo_grc) + this%forc_solar_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='FSDS_from_atm', units='W/m^2', & + avgflag='A', long_name='atmospheric incident solar radiation received from atmosphere (pre-downscaling)', & + ptr_lnd=this%forc_solar_not_downscaled_grc) + + this%forc_o3_grc(begg:endg) = spval call hist_addfld1d (fname='ATM_O3', units='mol/mol', & avgflag='A', long_name='atmospheric ozone partial pressure', & ptr_lnd=this%forc_o3_grc, default = 'inactive') - this%forc_solar_grc(begg:endg) = spval - call hist_addfld1d (fname='FSDS', units='W/m^2', & - avgflag='A', long_name='atmospheric incident solar radiation', & - ptr_lnd=this%forc_solar_grc) - this%forc_pco2_grc(begg:endg) = spval call hist_addfld1d (fname='PCO2', units='Pa', & avgflag='A', long_name='atmospheric partial pressure of CO2', & ptr_lnd=this%forc_pco2_grc) - this%forc_solar_grc(begg:endg) = spval + this%forc_solar_not_downscaled_grc(begg:endg) = spval call hist_addfld1d (fname='SWdown', units='W/m^2', & avgflag='A', long_name='atmospheric incident solar radiation', & - ptr_gcell=this%forc_solar_grc, default='inactive') + ptr_gcell=this%forc_solar_not_downscaled_grc, default='inactive') if (use_lch4) then this%forc_pch4_grc(begg:endg) = spval @@ -586,42 +590,46 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='atmospheric air temperature received from atmosphere (pre-downscaling)', & ptr_gcell=this%forc_t_not_downscaled_grc, default='inactive') + this%forc_solar_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname='FSDS', units='W/m^2', & + avgflag='A', long_name='atmospheric incident solar radiation (downscaled for glacier and hillslope columns)', & + ptr_col=this%forc_solar_downscaled_col) + this%forc_t_downscaled_col(begc:endc) = spval call hist_addfld1d (fname='TBOT', units='K', & - avgflag='A', long_name='atmospheric air temperature (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric air temperature (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_t_downscaled_col) call hist_addfld1d (fname='Tair', units='K', & - avgflag='A', long_name='atmospheric air temperature (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric air temperature (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_t_downscaled_col, default='inactive') this%forc_pbot_downscaled_col(begc:endc) = spval call hist_addfld1d (fname='PBOT', units='Pa', & - avgflag='A', long_name='atmospheric pressure at surface (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric pressure at surface (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_pbot_downscaled_col) call hist_addfld1d (fname='PSurf', units='Pa', & - avgflag='A', long_name='atmospheric pressure at surface (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric pressure at surface (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_pbot_downscaled_col, default='inactive') this%forc_lwrad_downscaled_col(begc:endc) = spval call hist_addfld1d (fname='FLDS', units='W/m^2', & - avgflag='A', long_name='atmospheric longwave radiation (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric longwave radiation (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_lwrad_downscaled_col) call hist_addfld1d (fname='LWdown', units='W/m^2', & - avgflag='A', long_name='atmospheric longwave radiation (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric longwave radiation (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_lwrad_downscaled_col, default='inactive') call hist_addfld1d (fname='FLDS_ICE', units='W/m^2', & avgflag='A', & - long_name='atmospheric longwave radiation (downscaled to columns in glacier regions) (ice landunits only)', & + long_name='atmospheric longwave radiation (downscaled for glacier and hillslope columns) (ice landunits only)', & ptr_col=this%forc_lwrad_downscaled_col, l2g_scale_type='ice', & default='inactive') this%forc_th_downscaled_col(begc:endc) = spval call hist_addfld1d (fname='THBOT', units='K', & - avgflag='A', long_name='atmospheric air potential temperature (downscaled to columns in glacier regions)', & + avgflag='A', long_name='atmospheric air potential temperature (downscaled for glacier and hillslope columns)', & ptr_col=this%forc_th_downscaled_col) - ! Time averaged quantities this%fsi24_patch(begp:endp) = spval call hist_addfld1d (fname='FSI24', units='K', & @@ -858,7 +866,7 @@ subroutine UpdateAccVars (this, bounds) ! Accumulate and extract forc_solad24 & forc_solad240 do p = begp,endp g = patch%gridcell(p) - rbufslp(p) = this%forc_solad_grc(g,1) + rbufslp(p) = this%forc_solad_not_downscaled_grc(g,1) end do call update_accum_field ('FSD240', rbufslp , nstep) call extract_accum_field ('FSD240', this%fsd240_patch , nstep) @@ -997,9 +1005,9 @@ subroutine Clean(this) deallocate(this%forc_hgt_q_grc) deallocate(this%forc_vp_grc) deallocate(this%forc_pco2_grc) - deallocate(this%forc_solad_grc) + deallocate(this%forc_solad_not_downscaled_grc) deallocate(this%forc_solai_grc) - deallocate(this%forc_solar_grc) + deallocate(this%forc_solar_not_downscaled_grc) deallocate(this%forc_ndep_grc) deallocate(this%forc_pc13o2_grc) deallocate(this%forc_po2_grc) @@ -1020,6 +1028,8 @@ subroutine Clean(this) deallocate(this%forc_th_downscaled_col) deallocate(this%forc_rho_downscaled_col) deallocate(this%forc_lwrad_downscaled_col) + deallocate(this%forc_solad_downscaled_col) + deallocate(this%forc_solar_downscaled_col) deallocate(this%fsd24_patch) deallocate(this%fsd240_patch) diff --git a/src/main/clm_driver.F90 b/src/main/clm_driver.F90 index 33e9412ba9..00a98e61b4 100644 --- a/src/main/clm_driver.F90 +++ b/src/main/clm_driver.F90 @@ -511,7 +511,7 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro atm_topo = atm2lnd_inst%forc_topo_grc(bounds_clump%begg:bounds_clump%endg)) call downscale_forcings(bounds_clump, & - topo_inst, atm2lnd_inst, water_inst%wateratm2lndbulk_inst, & + topo_inst, atm2lnd_inst, surfalb_inst, water_inst%wateratm2lndbulk_inst, & eflx_sh_precip_conversion = energyflux_inst%eflx_sh_precip_conversion_col(bounds_clump%begc:bounds_clump%endc)) call set_atm2lnd_water_tracers(bounds_clump, & @@ -1092,7 +1092,7 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro filter(nc)%num_hydrologyc, filter(nc)%hydrologyc, & filter(nc)%num_urbanc, filter(nc)%urbanc, & filter(nc)%num_do_smb_c, filter(nc)%do_smb_c, & - atm2lnd_inst, glc2lnd_inst, temperature_inst, & + glc2lnd_inst, temperature_inst, & soilhydrology_inst, soilstate_inst, water_inst%waterstatebulk_inst, & water_inst%waterdiagnosticbulk_inst, water_inst%waterbalancebulk_inst, & water_inst%waterfluxbulk_inst, water_inst%wateratm2lndbulk_inst, & diff --git a/src/main/clm_initializeMod.F90 b/src/main/clm_initializeMod.F90 index 3354c1e7d0..ab59ea5447 100644 --- a/src/main/clm_initializeMod.F90 +++ b/src/main/clm_initializeMod.F90 @@ -14,10 +14,10 @@ module clm_initializeMod use clm_varctl , only : use_fates_sp, use_fates_bgc, use_fates use clm_varctl , only : is_cold_start use clm_varctl , only : iulog - use clm_varctl , only : use_lch4, use_cn, use_cndv, use_c13, use_c14 + use clm_varctl , only : use_lch4, use_cn, use_cndv, use_c13, use_c14, nhillslope use clm_varctl , only : use_soil_moisture_streams use clm_instur , only : wt_lunit, urban_valid, wt_nat_patch, wt_cft, fert_cft - use clm_instur , only : irrig_method, wt_glc_mec, topo_glc_mec, haslake, pct_urban_max + use clm_instur , only : irrig_method, wt_glc_mec, topo_glc_mec, haslake, ncolumns_hillslope, pct_urban_max use perf_mod , only : t_startf, t_stopf use readParamsMod , only : readParameters use ncdio_pio , only : file_desc_t @@ -64,7 +64,8 @@ subroutine initialize1(dtime) use UrbanParamsType , only: IsSimpleBuildTemp use dynSubgridControlMod , only: dynSubgridControl_init use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_par_init - use CropReprPoolsMod , only: crop_repr_pools_init + use CropReprPoolsMod , only: crop_repr_pools_init + use HillslopeHydrologyMod, only: hillslope_properties_init ! ! !ARGUMENTS integer, intent(in) :: dtime ! model time step (seconds) @@ -114,6 +115,7 @@ subroutine initialize1(dtime) if (masterproc) call control_print() call dynSubgridControl_init(NLFilename) call crop_repr_pools_init() + call hillslope_properties_init(NLFilename) call t_stopf('clm_init1') @@ -135,6 +137,7 @@ subroutine initialize2(ni,nj) use clm_varctl , only : finidat, finidat_interp_source, finidat_interp_dest, fsurdat use clm_varctl , only : use_cn, use_fates, use_fates_luh use clm_varctl , only : use_crop, ndep_from_cpl, fates_spitfire_mode + use clm_varctl , only : use_hillslope use clm_varorb , only : eccen, mvelpp, lambm0, obliqr use clm_varctl , only : use_cropcal_streams use landunit_varcon , only : landunit_varcon_init, max_lunit, numurbl @@ -176,9 +179,10 @@ subroutine initialize2(ni,nj) use NutrientCompetitionFactoryMod , only : create_nutrient_competition_method use FATESFireFactoryMod , only : scalar_lightning use dynFATESLandUseChangeMod , only : dynFatesLandUseInit + use HillslopeHydrologyMod , only : InitHillslope ! ! !ARGUMENTS - integer, intent(in) :: ni, nj ! global grid sizes + integer, intent(in) :: ni, nj ! global grid sizes ! ! !LOCAL VARIABLES: integer :: c,g,i,j,k,l,n,p ! indices @@ -236,6 +240,9 @@ subroutine initialize2(ni,nj) allocate (wt_glc_mec (begg:endg, maxpatch_glc )) allocate (topo_glc_mec (begg:endg, maxpatch_glc )) allocate (haslake (begg:endg )) + if (use_hillslope) then + allocate (ncolumns_hillslope (begg:endg )) + endif allocate (pct_urban_max(begg:endg, numurbl )) allocate (wt_nat_patch (begg:endg, surfpft_lb:surfpft_ub )) @@ -293,6 +300,11 @@ subroutine initialize2(ni,nj) ! Set global seg maps for gridcells, landlunits, columns and patches call decompInit_glcp(ni, nj, glc_behavior) + if (use_hillslope) then + ! Initialize hillslope properties + call InitHillslope(bounds_proc, fsurdat) + endif + ! Set filters call allocFilters() @@ -318,6 +330,7 @@ subroutine initialize2(ni,nj) ! end of the run for error checking, pct_urban_max is kept through the end of the run ! for reweighting in subgridWeights. deallocate (wt_lunit, wt_cft, wt_glc_mec, haslake) + if (use_hillslope) deallocate (ncolumns_hillslope) ! Determine processor bounds and clumps for this processor call get_proc_bounds(bounds_proc) diff --git a/src/main/clm_instMod.F90 b/src/main/clm_instMod.F90 index 1ca450b48d..43390ca8b7 100644 --- a/src/main/clm_instMod.F90 +++ b/src/main/clm_instMod.F90 @@ -200,6 +200,9 @@ subroutine clm_instInit(bounds) use SoilWaterRetentionCurveFactoryMod , only : create_soil_water_retention_curve use decompMod , only : get_proc_bounds use BalanceCheckMod , only : GetBalanceCheckSkipSteps + use clm_varctl , only : use_hillslope + use HillslopeHydrologyMod , only : SetHillslopeSoilThickness + use initVerticalMod , only : setSoilLayerClass ! ! !ARGUMENTS type(bounds_type), intent(in) :: bounds ! processor bounds @@ -268,6 +271,14 @@ subroutine clm_instInit(bounds) urbanparams_inst%thick_wall(begl:endl), & urbanparams_inst%thick_roof(begl:endl)) + ! Set hillslope column bedrock values + if (use_hillslope) then + call SetHillslopeSoilThickness(bounds,fsurdat, & + soil_depth_lowland_in=8.5_r8,& + soil_depth_upland_in =2.0_r8) + call setSoilLayerClass(bounds) + endif + !----------------------------------------------- ! Set cold-start values for snow levels, snow layers and snow interfaces !----------------------------------------------- diff --git a/src/main/clm_varctl.F90 b/src/main/clm_varctl.F90 index 615f3b2606..bdcb653b64 100644 --- a/src/main/clm_varctl.F90 +++ b/src/main/clm_varctl.F90 @@ -152,6 +152,12 @@ module clm_varctl ! true => separate crop landunit is not created by default logical, public :: create_crop_landunit = .false. + ! number of hillslopes per landunit + integer, public :: nhillslope = 0 + + ! maximum number of hillslope columns per landunit + integer, public :: max_columns_hillslope = 1 + ! do not irrigate by default logical, public :: irrigate = .false. @@ -378,7 +384,15 @@ module clm_varctl integer, public :: soil_layerstruct_userdefined_nlevsoi = iundef !---------------------------------------------------------- - !excess ice physics switch + ! hillslope hydrology switch + !---------------------------------------------------------- + + logical, public :: use_hillslope = .false. ! true => use multi-column hillslope hydrology + logical, public :: downscale_hillslope_meteorology = .false. ! true => downscale meteorological forcing in hillslope model + logical, public :: use_hillslope_routing = .false. ! true => use surface water routing in hillslope hydrology + + !---------------------------------------------------------- + ! excess ice physics switch !---------------------------------------------------------- logical, public :: use_excess_ice = .false. ! true. => use excess ice physics diff --git a/src/main/clm_varsur.F90 b/src/main/clm_varsur.F90 index d360941d23..c49c8bb052 100644 --- a/src/main/clm_varsur.F90 +++ b/src/main/clm_varsur.F90 @@ -45,13 +45,17 @@ module clm_instur ! subgrid glacier_mec sfc elevation real(r8), pointer :: topo_glc_mec(:,:) - + ! whether we have lake to initialise in each grid cell logical , pointer :: haslake(:) + + ! subgrid hillslope hydrology constituents + integer, pointer :: ncolumns_hillslope(:) ! whether we have urban to initialize in each grid cell ! (second dimension goes 1:numurbl) real(r8), pointer :: pct_urban_max(:,:) + !----------------------------------------------------------------------- end module clm_instur diff --git a/src/main/controlMod.F90 b/src/main/controlMod.F90 index d95c0e28e0..eaa7c5c1e4 100644 --- a/src/main/controlMod.F90 +++ b/src/main/controlMod.F90 @@ -45,7 +45,7 @@ module controlMod use SoilBiogeochemLittVertTranspMod , only: som_adv_flux, max_depth_cryoturb use SoilBiogeochemVerticalProfileMod , only: surfprof_exp use SoilBiogeochemNitrifDenitrifMod , only: no_frozen_nitrif_denitrif - use SoilHydrologyMod , only: soilHydReadNML + use SoilHydrologyMod , only: soilHydReadNML, hillslope_hydrology_ReadNML use CNFireFactoryMod , only: CNFireReadNML use CanopyFluxesMod , only: CanopyFluxesReadNML use shr_drydep_mod , only: n_drydep @@ -257,6 +257,11 @@ subroutine control_init(dtime) namelist /clm_inparm/ use_biomass_heat_storage + namelist /clm_inparm/ use_hillslope + + namelist /clm_inparm/ downscale_hillslope_meteorology + + namelist /clm_inparm/ use_hillslope_routing namelist /clm_inparm/ use_hydrstress @@ -574,8 +579,10 @@ subroutine control_init(dtime) end if call soilHydReadNML( NLFilename ) - - if( use_cn ) then + if ( use_hillslope ) then + call hillslope_hydrology_ReadNML( NLFilename ) + endif + if ( use_cn ) then call CNFireReadNML( NLFilename ) call CNPrecisionControlReadNML( NLFilename ) call CNNDynamicsReadNML ( NLFilename ) @@ -816,6 +823,11 @@ subroutine control_spmd() call mpi_bcast (use_biomass_heat_storage, 1, MPI_LOGICAL, 0, mpicom, ier) + call mpi_bcast (use_hillslope, 1, MPI_LOGICAL, 0, mpicom, ier) + + call mpi_bcast (downscale_hillslope_meteorology, 1, MPI_LOGICAL, 0, mpicom, ier) + + call mpi_bcast (use_hillslope_routing, 1, MPI_LOGICAL, 0, mpicom, ier) call mpi_bcast (use_hydrstress, 1, MPI_LOGICAL, 0, mpicom, ier) @@ -1066,6 +1078,7 @@ subroutine control_print () write(iulog,'(a,d20.10)') ' Max snow depth (mm) =', h2osno_max write(iulog,'(a,i8)') ' glc number of elevation classes =', maxpatch_glc + if (glc_do_dynglacier) then write(iulog,*) ' glc CLM glacier areas and topography WILL evolve dynamically' else @@ -1098,6 +1111,9 @@ subroutine control_print () end if write(iulog,*) ' land-ice albedos (unitless 0-1) = ', albice + write(iulog,*) ' hillslope hydrology = ', use_hillslope + write(iulog,*) ' downscale hillslope meteorology = ', downscale_hillslope_meteorology + write(iulog,*) ' hillslope routing = ', use_hillslope_routing write(iulog,*) ' pre-defined soil layer structure = ', soil_layerstruct_predefined write(iulog,*) ' user-defined soil layer structure = ', soil_layerstruct_userdefined write(iulog,*) ' user-defined number of soil layers = ', soil_layerstruct_userdefined_nlevsoi diff --git a/src/main/histFileMod.F90 b/src/main/histFileMod.F90 index fb1a25db37..d419f97630 100644 --- a/src/main/histFileMod.F90 +++ b/src/main/histFileMod.F90 @@ -16,7 +16,7 @@ module histFileMod use clm_varctl , only : iulog, use_fates, compname, use_cn, use_crop use clm_varcon , only : spval, ispval use clm_varcon , only : grlnd, nameg, namel, namec, namep - use decompMod , only : get_proc_bounds, get_proc_global, bounds_type, get_global_index_array + use decompMod , only : get_proc_bounds, get_proc_global, bounds_type, get_global_index, get_global_index_array use decompMod , only : subgrid_level_gridcell, subgrid_level_landunit, subgrid_level_column use GridcellType , only : grc use LandunitType , only : lun @@ -2329,6 +2329,7 @@ subroutine htape_create (t, histrest) use landunit_varcon , only : max_lunit use clm_varctl , only : caseid, ctitle, fsurdat, finidat, paramfile use clm_varctl , only : version, hostname, username, conventions, source + use clm_varctl , only : use_hillslope,nhillslope,max_columns_hillslope use domainMod , only : ldomain use fileutils , only : get_filename ! @@ -2466,6 +2467,10 @@ subroutine htape_create (t, histrest) call ncd_defdim(lnfid, 'ltype', max_lunit, dimid) call ncd_defdim(lnfid, 'nlevcan',nlevcan, dimid) call ncd_defdim(lnfid, 'nvegwcs',nvegwcs, dimid) + if (use_hillslope) then + call ncd_defdim(lnfid, 'nhillslope',nhillslope, dimid) + call ncd_defdim(lnfid, 'max_columns_hillslope',max_columns_hillslope, dimid) + endif call ncd_defdim(lnfid, 'mxsowings' , mxsowings , dimid) call ncd_defdim(lnfid, 'mxharvests' , mxharvests , dimid) call htape_add_ltype_metadata(lnfid) @@ -2487,7 +2492,6 @@ subroutine htape_create (t, histrest) call ncd_defdim(lnfid, 'scale_type_string_length', scale_type_strlen, dimid) call ncd_defdim( lnfid, 'levdcmp', nlevdecomp_full, dimid) - if(use_fates)then call ncd_defdim(lnfid, 'fates_levscag', nlevsclass * nlevage, dimid) call ncd_defdim(lnfid, 'fates_levscagpf', nlevsclass * nlevage * numpft_fates, dimid) @@ -2730,6 +2734,7 @@ subroutine htape_timeconst3D(t, & 'lake', & ! ZLAKE 'lake' & ! DZLAKE ] + !----------------------------------------------------------------------- SHR_ASSERT_ALL_FL((ubound(watsat_col) == (/bounds%endc, nlevmaxurbgrnd/)), sourcefile, __LINE__) @@ -3024,7 +3029,8 @@ subroutine htape_timeconst(t, mode) ! ! !USES: use clm_varpar , only : nlevsoi - use clm_varcon , only : zsoi, zlak, secspday, isecspday, isecsphr, isecspmin + use clm_varctl , only : use_hillslope + use clm_varcon , only : zsoi, zlak, secspday, isecspday, isecsphr, isecspmin, ispval use domainMod , only : ldomain, lon1d, lat1d use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time use clm_time_manager, only : get_ref_date, get_calendar, NO_LEAP_C, GREGORIAN_C @@ -3079,7 +3085,7 @@ subroutine htape_timeconst(t, mode) ! integer :: sec_hist_nhtfrq ! hist_nhtfrq converted to seconds ! !LOCAL VARIABLES: - integer :: vid,n,i,j,m ! indices + integer :: vid,n,i,j,m,c ! indices integer :: nstep ! current step integer :: mcsec ! seconds of current date integer :: mdcur ! current day @@ -3105,6 +3111,9 @@ subroutine htape_timeconst(t, mode) real(r8), pointer :: histo(:,:) ! temporary integer :: status real(r8) :: zsoi_1d(1) + type(bounds_type) :: bounds + integer :: ier ! error status + integer, pointer :: icarr(:) ! temporary character(len=*),parameter :: subname = 'htape_timeconst' !----------------------------------------------------------------------- @@ -3112,6 +3121,9 @@ subroutine htape_timeconst(t, mode) !*** Time constant grid variables only on first time-sample of file *** !------------------------------------------------------------------------------- + call get_proc_bounds(bounds) + + if (tape(t)%ntimes == 1) then if (mode == 'define') then call ncd_defvar(varname='levgrnd', xtype=tape(t)%ncprec, & @@ -3126,6 +3138,36 @@ subroutine htape_timeconst(t, mode) call ncd_defvar(varname='levdcmp', xtype=tape(t)%ncprec, dim1name='levdcmp', & long_name='coordinate levels for soil decomposition variables', units='m', ncid=nfid(t)) + if (use_hillslope .and. .not.tape(t)%dov2xy)then + call ncd_defvar(varname='hillslope_distance', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column distance', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_width', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column width', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_area', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column area', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_elev', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column elevation', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_slope', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column slope', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_aspect', xtype=ncd_double, & + dim1name=namec, long_name='hillslope column aspect', & + units='m', ncid=nfid(t)) + call ncd_defvar(varname='hillslope_index', xtype=ncd_int, & + dim1name=namec, long_name='hillslope index', & + ncid=nfid(t)) + call ncd_defvar(varname='hillslope_cold', xtype=ncd_int, & + dim1name=namec, long_name='hillslope downhill column index', & + ncid=nfid(t)) + call ncd_defvar(varname='hillslope_colu', xtype=ncd_int, & + dim1name=namec, long_name='hillslope uphill column index', & + ncid=nfid(t)) + end if + if(use_fates)then call ncd_defvar(varname='fates_levscls', xtype=tape(t)%ncprec, dim1name='fates_levscls', & @@ -3214,6 +3256,44 @@ subroutine htape_timeconst(t, mode) zsoi_1d(1) = 1._r8 call ncd_io(varname='levdcmp', data=zsoi_1d, ncid=nfid(t), flag='write') end if + + if (use_hillslope .and. .not.tape(t)%dov2xy) then + call ncd_io(varname='hillslope_distance' , data=col%hill_distance, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_width' , data=col%hill_width, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_area' , data=col%hill_area, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_elev' , data=col%hill_elev, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_slope' , data=col%hill_slope, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_aspect' , data=col%hill_aspect, dim1name=namec, ncid=nfid(t), flag='write') + call ncd_io(varname='hillslope_index' , data=col%hillslope_ndx, dim1name=namec, ncid=nfid(t), flag='write') + + ! write global indices rather than local indices + allocate(icarr(bounds%begc:bounds%endc),stat=ier) + if (ier /= 0) then + call endrun(msg=' allocation error of icarr'//errMsg(sourcefile, __LINE__)) + end if + + do c = bounds%begc,bounds%endc + if (col%cold(c) /= ispval) then + icarr(c)= get_global_index(subgrid_index=col%cold(c), subgrid_level=subgrid_level_column) + else + icarr(c)= col%cold(c) + endif + enddo + + call ncd_io(varname='hillslope_cold' , data=icarr, dim1name=namec, ncid=nfid(t), flag='write') + + do c = bounds%begc,bounds%endc + if (col%colu(c) /= ispval) then + icarr(c)= get_global_index(subgrid_index=col%colu(c), subgrid_level=subgrid_level_column) + else + icarr(c)= col%colu(c) + endif + enddo + + call ncd_io(varname='hillslope_colu' , data=icarr, dim1name=namec, ncid=nfid(t), flag='write') + deallocate(icarr) + endif + if(use_fates)then call ncd_io(varname='fates_scmap_levscag',data=fates_hdim_scmap_levscag, ncid=nfid(t), flag='write') call ncd_io(varname='fates_agmap_levscag',data=fates_hdim_agmap_levscag, ncid=nfid(t), flag='write') @@ -3765,6 +3845,9 @@ subroutine hfields_1dinfo(t, mode) call ncd_defvar(varname='cols1d_active', xtype=ncd_log, dim1name=namec, & long_name='true => do computations on this column', ifill_value=0, ncid=ncid) + call ncd_defvar(varname='cols1d_nbedrock', xtype=ncd_int, dim1name=namec, & + long_name='column bedrock depth index', ifill_value=ispval, ncid=ncid) + ! Define patch info call ncd_defvar(varname='pfts1d_lon', xtype=ncd_double, dim1name=namep, & @@ -3912,6 +3995,7 @@ subroutine hfields_1dinfo(t, mode) call ncd_io(varname='cols1d_itype_lunit', data=icarr , dim1name=namec, ncid=ncid, flag='write') call ncd_io(varname='cols1d_active' , data=col%active , dim1name=namec, ncid=ncid, flag='write') + call ncd_io(varname='cols1d_nbedrock', data=col%nbedrock , dim1name=namec, ncid=ncid, flag='write') ! Write patch info @@ -4107,7 +4191,7 @@ subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & call htape_timeconst(t, mode='define') ! Define 3D time-constant field variables on first history tapes - if ( do_3Dtconst) then + if ( do_3Dtconst .and. t == 1) then call htape_timeconst3D(t, & bounds, watsat_col, sucsat_col, bsw_col, hksat_col, & cellsand_col, cellclay_col, mode='define') @@ -4127,7 +4211,7 @@ subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & call htape_timeconst(t, mode='write') ! Write 3D time constant history variables to first history tapes - if ( do_3Dtconst .and. tape(t)%ntimes == 1 )then + if ( do_3Dtconst .and. t == 1 .and. tape(t)%ntimes == 1 )then call htape_timeconst3D(t, & bounds, watsat_col, sucsat_col, bsw_col, hksat_col, & cellsand_col, cellclay_col, mode='write') @@ -4581,7 +4665,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) start(1)=1 - ! ! Add history namelist data to each history restart tape ! diff --git a/src/main/initGridCellsMod.F90 b/src/main/initGridCellsMod.F90 index 99303c32da..44bc9361b2 100644 --- a/src/main/initGridCellsMod.F90 +++ b/src/main/initGridCellsMod.F90 @@ -216,7 +216,7 @@ subroutine set_landunit_veg_compete (ltype, gi, li, ci, pi) integer , intent(inout) :: pi ! patch index ! ! !LOCAL VARIABLES: - integer :: m ! index + integer :: m, ci2 ! index integer :: npatches ! number of patches in landunit integer :: ncols integer :: nlunits @@ -224,6 +224,7 @@ subroutine set_landunit_veg_compete (ltype, gi, li, ci, pi) integer :: ncols_added ! number of columns actually added integer :: nlunits_added ! number of landunits actually added real(r8) :: wtlunit2gcell ! landunit weight in gridcell + real(r8) :: wtcol2lunit ! column weight in landunit real(r8) :: p_wt ! patch weight (0-1) !------------------------------------------------------------------------ @@ -240,31 +241,37 @@ subroutine set_landunit_veg_compete (ltype, gi, li, ci, pi) if (nlunits > 0) then call add_landunit(li=li, gi=gi, ltype=ltype, wtgcell=wtlunit2gcell) nlunits_added = nlunits_added + 1 - - ! Assume one column on the landunit - call add_column(ci=ci, li=li, ctype=1, wtlunit=1.0_r8) - ncols_added = ncols_added + 1 - - ! For FATES: the total number of patches may not match what is in the surface - ! file, and therefor the weighting can't be used. The weightings in - ! wt_nat_patch may be meaningful (like with fixed biogeography), but they - ! they need a mapping table to connect to the allocated patches (in fates) - ! so the wt_nat_patch array is not applicable to these area weights - ! A subsequent call, via the clmfates interface will update these weights - ! by using said mapping table - - do m = natpft_lb,natpft_ub - if (natveg_patch_exists(gi, m)) then - if(use_fates .and. .not.use_fates_sp)then - p_wt = 1.0_r8/real(natpft_size,r8) - else - p_wt = wt_nat_patch(gi,m) + + ! Potentially create multiple columns (e.g., for hillslope hydrology), but each + ! with the same PFT breakdown. + ! + ! Set column weight arbitrarily for now. If we have multiple columns because we're + ! using hillslope hydrology, then col%wtlunit will be modified in InitHillslope. + wtcol2lunit = 1.0_r8/real(ncols,r8) + do ci2 = 1,ncols + call add_column(ci=ci, li=li, ctype=1, wtlunit=wtcol2lunit) + ncols_added = ncols_added + 1 + + ! For FATES: the total number of patches may not match what is in the surface + ! file, and therefor the weighting can't be used. The weightings in + ! wt_nat_patch may be meaningful (like with fixed biogeography), but they + ! they need a mapping table to connect to the allocated patches (in fates) + ! so the wt_nat_patch array is not applicable to these area weights + ! A subsequent call, via the clmfates interface will update these weights + ! by using said mapping table + + do m = natpft_lb,natpft_ub + if (natveg_patch_exists(gi, m)) then + if(use_fates .and. .not.use_fates_sp)then + p_wt = 1.0_r8/real(natpft_size,r8) + else + p_wt = wt_nat_patch(gi,m) + end if + call add_patch(pi=pi, ci=ci, ptype=m, wtcol=p_wt) + npatches_added = npatches_added + 1 end if - call add_patch(pi=pi, ci=ci, ptype=m, wtcol=p_wt) - npatches_added = npatches_added + 1 - end if + end do end do - end if SHR_ASSERT_FL(nlunits_added == nlunits, sourcefile, __LINE__) diff --git a/src/main/initVerticalMod.F90 b/src/main/initVerticalMod.F90 index 1bf79706f9..e88c4e1a18 100644 --- a/src/main/initVerticalMod.F90 +++ b/src/main/initVerticalMod.F90 @@ -40,7 +40,8 @@ module initVerticalMod public :: initVertical public :: find_soil_layer_containing_depth public :: readParams - + public :: setSoilLayerClass + ! !PRIVATE MEMBER FUNCTIONS: private :: hasBedrock ! true if the given column type includes bedrock layers type, private :: params_type @@ -80,9 +81,75 @@ subroutine readParams( ncid ) end subroutine readParams + !------------------------------------------------------------------------ + subroutine setSoilLayerClass(bounds) + + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + ! + ! LOCAL VARAIBLES: + integer :: c,l,j ! indices + + ! Possible values for levgrnd_class. The important thing is that, for a given column, + ! layers that are fundamentally different (e.g., soil vs bedrock) have different + ! values. This information is used in the vertical interpolation in init_interp. + ! + ! IMPORTANT: These values should not be changed lightly. e.g., try to avoid changing + ! the values assigned to LEVGRND_CLASS_STANDARD, LEVGRND_CLASS_DEEP_BEDROCK, etc. The + ! problem with changing these is that init_interp expects that layers with a value of + ! (e.g.) 1 on the source file correspond to layers with a value of 1 on the + ! destination file. So if you change the values of these constants, you either need to + ! adequately inform users of this change, or build in some translation mechanism in + ! init_interp (such as via adding more metadata to the restart file on the meaning of + ! these different values). + ! + ! The distinction between "shallow" and "deep" bedrock is not made explicitly + ! elsewhere. But, since these classes have somewhat different behavior, they are + ! distinguished explicitly here. + integer, parameter :: LEVGRND_CLASS_STANDARD = 1 + integer, parameter :: LEVGRND_CLASS_DEEP_BEDROCK = 2 + integer, parameter :: LEVGRND_CLASS_SHALLOW_BEDROCK = 3 + + character(len=*), parameter :: subname = 'setSoilLayerClass' + + ! ------------------------------------------------------------------------ + ! Set classes of layers + ! ------------------------------------------------------------------------ + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (hasBedrock(col_itype=col%itype(c), lun_itype=lun%itype(l))) then + ! NOTE(wjs, 2015-10-17) We are assuming that points with bedrock have both + ! "shallow" and "deep" bedrock. Currently, this is not true for lake columns: + ! lakes do not distinguish between "shallow" bedrock and "normal" soil. + ! However, that was just due to an oversight that is supposed to be corrected + ! soon; so to keep things simple we assume that any point with bedrock + ! potentially has both shallow and deep bedrock. + col%levgrnd_class(c, 1:col%nbedrock(c)) = LEVGRND_CLASS_STANDARD + if (col%nbedrock(c) < nlevsoi) then + col%levgrnd_class(c, (col%nbedrock(c) + 1) : nlevsoi) = LEVGRND_CLASS_SHALLOW_BEDROCK + end if + col%levgrnd_class(c, (nlevsoi + 1) : nlevmaxurbgrnd) = LEVGRND_CLASS_DEEP_BEDROCK + else + col%levgrnd_class(c, 1:nlevmaxurbgrnd) = LEVGRND_CLASS_STANDARD + end if + end do + + do j = 1, nlevmaxurbgrnd + do c = bounds%begc, bounds%endc + if (col%z(c,j) == spval) then + col%levgrnd_class(c,j) = ispval + end if + end do + end do + + end subroutine setSoilLayerClass + !------------------------------------------------------------------------ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) - use clm_varcon, only : zmin_bedrock + use clm_varcon , only : zmin_bedrock + ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds @@ -91,7 +158,7 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) real(r8) , intent(in) :: thick_roof(bounds%begl:) ! ! LOCAL VARAIBLES: - integer :: c,l,g,i,j,lev ! indices + integer :: c,l,g,i,j,lev ! indices type(file_desc_t) :: ncid ! netcdf id logical :: readvar integer :: dimid ! dimension id @@ -115,27 +182,6 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) integer :: begc, endc integer :: begl, endl integer :: jmin_bedrock - - ! Possible values for levgrnd_class. The important thing is that, for a given column, - ! layers that are fundamentally different (e.g., soil vs bedrock) have different - ! values. This information is used in the vertical interpolation in init_interp. - ! - ! IMPORTANT: These values should not be changed lightly. e.g., try to avoid changing - ! the values assigned to LEVGRND_CLASS_STANDARD, LEVGRND_CLASS_DEEP_BEDROCK, etc. The - ! problem with changing these is that init_interp expects that layers with a value of - ! (e.g.) 1 on the source file correspond to layers with a value of 1 on the - ! destination file. So if you change the values of these constants, you either need to - ! adequately inform users of this change, or build in some translation mechanism in - ! init_interp (such as via adding more metadata to the restart file on the meaning of - ! these different values). - ! - ! The distinction between "shallow" and "deep" bedrock is not made explicitly - ! elsewhere. But, since these classes have somewhat different behavior, they are - ! distinguished explicitly here. - integer, parameter :: LEVGRND_CLASS_STANDARD = 1 - integer, parameter :: LEVGRND_CLASS_DEEP_BEDROCK = 2 - integer, parameter :: LEVGRND_CLASS_SHALLOW_BEDROCK = 3 - character(len=*), parameter :: subname = 'initVertical' !------------------------------------------------------------------------ @@ -224,7 +270,7 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) dzsoi(j) = soil_layerstruct_userdefined(j) end do else if (soil_layerstruct_predefined == '49SL_10m') then - !scs: 10 meter soil column, nlevsoi set to 49 in clm_varpar + ! 10 meter soil column, nlevsoi set to 49 in clm_varpar do j = 1, 10 dzsoi(j) = 1.e-2_r8 ! 10-mm layers enddo @@ -639,36 +685,11 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) end if end do - ! ------------------------------------------------------------------------ + ! ---------------------------------------------- ! Set classes of layers - ! ------------------------------------------------------------------------ + ! ---------------------------------------------- - do c = bounds%begc, bounds%endc - l = col%landunit(c) - if (hasBedrock(col_itype=col%itype(c), lun_itype=lun%itype(l))) then - ! NOTE(wjs, 2015-10-17) We are assuming that points with bedrock have both - ! "shallow" and "deep" bedrock. Currently, this is not true for lake columns: - ! lakes do not distinguish between "shallow" bedrock and "normal" soil. - ! However, that was just due to an oversight that is supposed to be corrected - ! soon; so to keep things simple we assume that any point with bedrock - ! potentially has both shallow and deep bedrock. - col%levgrnd_class(c, 1:col%nbedrock(c)) = LEVGRND_CLASS_STANDARD - if (col%nbedrock(c) < nlevsoi) then - col%levgrnd_class(c, (col%nbedrock(c) + 1) : nlevsoi) = LEVGRND_CLASS_SHALLOW_BEDROCK - end if - col%levgrnd_class(c, (nlevsoi + 1) : nlevmaxurbgrnd) = LEVGRND_CLASS_DEEP_BEDROCK - else - col%levgrnd_class(c, 1:nlevmaxurbgrnd) = LEVGRND_CLASS_STANDARD - end if - end do - - do j = 1, nlevmaxurbgrnd - do c = bounds%begc, bounds%endc - if (col%z(c,j) == spval) then - col%levgrnd_class(c,j) = ispval - end if - end do - end do + call setSoilLayerClass(bounds) !----------------------------------------------- ! Read in topographic index and slope @@ -707,7 +728,13 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) do c = begc,endc ! microtopographic parameter, units are meters (try smooth function of slope) slope0 = params_inst%slopemax**(1._r8/params_inst%slopebeta) - col%micro_sigma(c) = (col%topo_slope(c) + slope0)**(params_inst%slopebeta) + + if (col%is_hillslope_column(c)) then + col%micro_sigma(c) = (atan(col%hill_slope(c)) + slope0)**(params_inst%slopebeta) + else + col%micro_sigma(c) = (col%topo_slope(c) + slope0)**(params_inst%slopebeta) + endif + end do call ncd_pio_closefile(ncid) diff --git a/src/main/lnd2atmMod.F90 b/src/main/lnd2atmMod.F90 index 27769a69de..1cda0cff91 100644 --- a/src/main/lnd2atmMod.F90 +++ b/src/main/lnd2atmMod.F90 @@ -15,7 +15,7 @@ module lnd2atmMod use clm_varctl , only : iulog, use_lch4 use shr_drydep_mod , only : n_drydep use decompMod , only : bounds_type - use subgridAveMod , only : p2g, c2g + use subgridAveMod , only : p2g, c2g, l2g use filterColMod , only : filter_col_type, col_filter_from_logical_array use lnd2atmType , only : lnd2atm_type use atm2lndType , only : atm2lnd_type @@ -159,6 +159,7 @@ subroutine lnd2atm(bounds, & ! ! !USES: use ch4varcon , only : ch4offline + use clm_varctl , only : use_hillslope_routing ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds @@ -179,8 +180,11 @@ subroutine lnd2atm(bounds, & real(r8) , intent(in) :: net_carbon_exchange_grc( bounds%begg: ) ! net carbon exchange between land and atmosphere, positive for source (gC/m2/s) ! ! !LOCAL VARIABLES: - integer :: c, g ! indices + integer :: c, l, g ! indices real(r8) :: eflx_sh_ice_to_liq_grc(bounds%begg:bounds%endg) ! sensible heat flux generated from the ice to liquid conversion, averaged to gridcell + real(r8), allocatable :: qflx_surf_col_to_rof(:) ! surface runoff that is sent directly to rof + real(r8), allocatable :: qflx_drain_col_to_rof(:) ! drainagec that is sent directly to rof + real(r8), allocatable :: qflx_drain_perched_col_to_rof(:) ! perched drainage that is sent directly to rof real(r8), parameter :: amC = 12.0_r8 ! Atomic mass number for Carbon real(r8), parameter :: amO = 16.0_r8 ! Atomic mass number for Oxygen real(r8), parameter :: amCO2 = amC + 2.0_r8*amO ! Atomic mass number for CO2 @@ -336,15 +340,80 @@ subroutine lnd2atm(bounds, & ! lnd -> rof !---------------------------------------------------- - call c2g( bounds, & - water_inst%waterfluxbulk_inst%qflx_surf_col (bounds%begc:bounds%endc), & - water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsur_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + if (use_hillslope_routing) then + ! streamflow is volume/time, so sum over landunits (do not weight) + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_stream_grc(bounds%begg:bounds%endg) = 0._r8 + do l = bounds%begl, bounds%endl + if(lun%active(l)) then + g = lun%gridcell(l) + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_stream_grc(g) = & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_stream_grc(g) & + + water_inst%waterfluxbulk_inst%volumetric_streamflow_lun(l) & + *1e3_r8/(grc%area(g)*1.e6_r8) + endif + enddo + + ! If hillslope routing is used, exclude inputs to stream channel from gridcell averages to avoid double counting + allocate( & + qflx_surf_col_to_rof(bounds%begc:bounds%endc), & + qflx_drain_col_to_rof(bounds%begc:bounds%endc), & + qflx_drain_perched_col_to_rof(bounds%begc:bounds%endc)) + + qflx_surf_col_to_rof(bounds%begc:bounds%endc) = 0._r8 + qflx_drain_col_to_rof(bounds%begc:bounds%endc) = 0._r8 + qflx_drain_perched_col_to_rof(bounds%begc:bounds%endc) = 0._r8 + + do c = bounds%begc, bounds%endc + ! Exclude hillslope columns from gridcell average + ! hillslope runoff is sent to stream rather than directly + ! to rof, and is accounted for in qflx_rofliq_stream_grc + if (col%active(c) .and. .not. col%is_hillslope_column(c)) then + qflx_surf_col_to_rof(c) = qflx_surf_col_to_rof(c) & + + water_inst%waterfluxbulk_inst%qflx_surf_col(c) + qflx_drain_col_to_rof(c) = qflx_drain_col_to_rof(c) & + + water_inst%waterfluxbulk_inst%qflx_drain_col(c) + qflx_drain_perched_col_to_rof(c) = & + qflx_drain_perched_col_to_rof(c) & + + water_inst%waterfluxbulk_inst%qflx_drain_perched_col(c) + endif + enddo + + call c2g( bounds, & + qflx_surf_col_to_rof (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsur_grc (bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity') + + call c2g( bounds, & + qflx_drain_col_to_rof (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsub_grc (bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity') + + call c2g( bounds, & + qflx_drain_perched_col_to_rof (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_drain_perched_grc(bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity') + + deallocate(qflx_surf_col_to_rof,qflx_drain_col_to_rof, & + qflx_drain_perched_col_to_rof) + + else + + call c2g( bounds, & + water_inst%waterfluxbulk_inst%qflx_surf_col (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsur_grc (bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + + call c2g( bounds, & + water_inst%waterfluxbulk_inst%qflx_drain_col (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsub_grc (bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + + call c2g( bounds, & + water_inst%waterfluxbulk_inst%qflx_drain_perched_col (bounds%begc:bounds%endc), & + water_inst%waterlnd2atmbulk_inst%qflx_rofliq_drain_perched_grc(bounds%begg:bounds%endg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - call c2g( bounds, & - water_inst%waterfluxbulk_inst%qflx_drain_col (bounds%begc:bounds%endc), & - water_inst%waterlnd2atmbulk_inst%qflx_rofliq_qsub_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + endif do c = bounds%begc, bounds%endc if (col%active(c)) then @@ -383,12 +452,6 @@ subroutine lnd2atm(bounds, & water_inst%waterfluxbulk_inst%qflx_liq_dynbal_grc(g) enddo - call c2g( bounds, & - water_inst%waterfluxbulk_inst%qflx_drain_perched_col (bounds%begc:bounds%endc), & - water_inst%waterlnd2atmbulk_inst%qflx_rofliq_drain_perched_grc(bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - call c2g( bounds, & water_inst%waterfluxbulk_inst%qflx_sfc_irrig_col (bounds%begc:bounds%endc), & water_inst%waterlnd2atmbulk_inst%qirrig_grc(bounds%begg:bounds%endg), & diff --git a/src/main/lnd2glcMod.F90 b/src/main/lnd2glcMod.F90 index 34f50266ad..27fa7639d7 100644 --- a/src/main/lnd2glcMod.F90 +++ b/src/main/lnd2glcMod.F90 @@ -20,7 +20,7 @@ module lnd2glcMod use decompMod , only : get_proc_bounds, bounds_type, subgrid_level_column use domainMod , only : ldomain use clm_varpar , only : maxpatch_glc - use clm_varctl , only : iulog + use clm_varctl , only : iulog, use_hillslope use clm_varcon , only : spval, tfrz use column_varcon , only : col_itype_to_ice_class use landunit_varcon , only : istice, istsoil @@ -204,7 +204,16 @@ subroutine update_lnd2glc(this, bounds, num_do_smb_c, filter_do_smb_c, & ! Make sure we haven't already assigned the coupling fields for this point ! (this could happen, for example, if there were multiple columns in the ! istsoil landunit, which we aren't prepared to handle) - if (fields_assigned(g,n)) then + ! + ! BUG(wjs, 2022-07-17, ESCOMP/CTSM#204) We have a known bug in the handling of bare + ! land fluxes when we potentially have multiple vegetated columns in a grid cell. + ! The most common configuration where this is the case is when use_hillslope is + ! true. In order to allow hillslope hydrology runs to work for now, we are + ! bypassing this error check when use_hillslope is true - under the assumption + ! that, for now, people aren't going to be interested in SMB in a run with + ! hillslope hydrology. Once we resolve ESCOMP/CTSM#204, we should remove the '.and. + ! .not. use_hillslope' part of this conditional. + if (fields_assigned(g,n) .and. .not. use_hillslope) then write(iulog,*) subname//' ERROR: attempt to assign coupling fields twice for the same index.' write(iulog,*) 'One possible cause is having multiple columns in the istsoil landunit,' write(iulog,*) 'which this routine cannot handle.' diff --git a/src/main/subgridAveMod.F90 b/src/main/subgridAveMod.F90 index c5ce4a4a98..68431582ce 100644 --- a/src/main/subgridAveMod.F90 +++ b/src/main/subgridAveMod.F90 @@ -100,6 +100,70 @@ module subgridAveMod contains + !----------------------------------------------------------------------- + subroutine set_c2l_scale (bounds, c2l_scale_type, scale_c2l) + ! + ! !DESCRIPTION: + ! Set scale_c2l for different c2l_scale_type values + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) + real(r8), intent(out) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor for column->landunit mapping + + ! + ! !LOCAL VARIABLES: + integer :: c,l ! indices + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(scale_c2l) == (/bounds%endc/)), sourcefile, __LINE__) + + if (c2l_scale_type == 'unity') then + do c = bounds%begc,bounds%endc + scale_c2l(c) = 1.0_r8 + end do + else if (c2l_scale_type == 'urbanf') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0_r8 + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else if (c2l_scale_type == 'urbans') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else + write(iulog,*)'set_c2l_scale: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end subroutine set_c2l_scale + !----------------------------------------------------------------------- subroutine p2c_1d (bounds, parr, carr, p2c_scale_type) ! @@ -310,48 +374,7 @@ subroutine p2l_1d (bounds, parr, larr, p2c_scale_type, c2l_scale_type) SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp/)), sourcefile, __LINE__) SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl/)), sourcefile, __LINE__) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'p2l_1d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) if (p2c_scale_type == 'unity') then do p = bounds%begp,bounds%endp @@ -418,48 +441,7 @@ subroutine p2l_2d(bounds, num2d, parr, larr, p2c_scale_type, c2l_scale_type) SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp, num2d/)), sourcefile, __LINE__) SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl, num2d/)), sourcefile, __LINE__) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'p2l_2d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) if (p2c_scale_type == 'unity') then do p = bounds%begp,bounds%endp @@ -532,48 +514,7 @@ subroutine p2g_1d(bounds, parr, garr, p2c_scale_type, c2l_scale_type, l2g_scale_ call build_scale_l2g(bounds, l2g_scale_type, & scale_l2g(bounds%begl:bounds%endl)) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'p2g_1d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) if (p2c_scale_type == 'unity') then do p = bounds%begp,bounds%endp @@ -648,48 +589,7 @@ subroutine p2g_2d(bounds, num2d, parr, garr, p2c_scale_type, c2l_scale_type, l2g call build_scale_l2g(bounds, l2g_scale_type, & scale_l2g(bounds%begl:bounds%endl)) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'p2g_2d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) if (p2c_scale_type == 'unity') then do p = bounds%begp,bounds%endp @@ -770,48 +670,7 @@ subroutine c2l_1d (bounds, carr, larr, c2l_scale_type, include_inactive) l_include_inactive = .false. end if - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) larr(bounds%begl : bounds%endl) = spval sumwt(bounds%begl : bounds%endl) = 0._r8 @@ -866,48 +725,7 @@ subroutine c2l_2d (bounds, num2d, carr, larr, c2l_scale_type) SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc, num2d/)), sourcefile, __LINE__) SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl, num2d/)), sourcefile, __LINE__) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'c2l_2d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) larr(bounds%begl : bounds%endl, :) = spval do j = 1,num2d @@ -968,48 +786,7 @@ subroutine c2g_1d(bounds, carr, garr, c2l_scale_type, l2g_scale_type) call build_scale_l2g(bounds, l2g_scale_type, & scale_l2g(bounds%begl:bounds%endl)) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) garr(bounds%begg : bounds%endg) = spval sumwt(bounds%begg : bounds%endg) = 0._r8 @@ -1070,48 +847,7 @@ subroutine c2g_2d(bounds, num2d, carr, garr, c2l_scale_type, l2g_scale_type) call build_scale_l2g(bounds, l2g_scale_type, & scale_l2g(bounds%begl:bounds%endl)) - if (c2l_scale_type == 'unity') then - do c = bounds%begc,bounds%endc - scale_c2l(c) = 1.0_r8 - end do - else if (c2l_scale_type == 'urbanf') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = 3.0 * lun%canyon_hwr(l) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0_r8 - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else if (c2l_scale_type == 'urbans') then - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%urbpoi(l)) then - if (col%itype(c) == icol_sunwall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_shadewall) then - scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then - scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) - else if (col%itype(c) == icol_roof) then - scale_c2l(c) = 1.0_r8 - end if - else - scale_c2l(c) = 1.0_r8 - end if - end do - else - write(iulog,*)'c2g_2d error: scale type ',c2l_scale_type,' not supported' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + call set_c2l_scale (bounds, c2l_scale_type, scale_c2l) garr(bounds%begg : bounds%endg,:) = spval do j = 1,num2d diff --git a/src/main/subgridMod.F90 b/src/main/subgridMod.F90 index 7020f42be5..4118ac73ed 100644 --- a/src/main/subgridMod.F90 +++ b/src/main/subgridMod.F90 @@ -75,6 +75,8 @@ subroutine subgrid_get_gcellinfo (gi, glc_behavior, & ! atm_topo is arbitrary for the sake of getting these counts. We don't have a true ! atm_topo value at the point of this call, so use 0. real(r8), parameter :: atm_topo = 0._r8 + + !------------------------------------------------------------------------------ npatches = 0 @@ -85,6 +87,11 @@ subroutine subgrid_get_gcellinfo (gi, glc_behavior, & call subgrid_get_info_natveg(gi, npatches_temp, ncols_temp, nlunits_temp) call accumulate_counters() + ! call this after natveg call because we allocate space for + ! FATES cohorts based on the number of naturally vegetated columns + ! and nothing else + call subgrid_get_info_cohort(gi, ncols_temp, ncohorts) + call subgrid_get_info_urban_tbd(gi, npatches_temp, ncols_temp, nlunits_temp) call accumulate_counters() @@ -107,8 +114,6 @@ subroutine subgrid_get_gcellinfo (gi, glc_behavior, & call subgrid_get_info_crop(gi, npatches_temp, ncols_temp, nlunits_temp) call accumulate_counters() - call subgrid_get_info_cohort(gi,ncohorts) - contains subroutine accumulate_counters ! Accumulate running sums of patches, columns and landunits. @@ -131,6 +136,8 @@ subroutine subgrid_get_info_natveg(gi, npatches, ncols, nlunits) ! ! !USES use clm_varpar, only : natpft_lb, natpft_ub + use clm_instur, only : ncolumns_hillslope + use clm_varctl, only : use_hillslope ! ! !ARGUMENTS: integer, intent(in) :: gi ! grid cell index @@ -154,9 +161,16 @@ subroutine subgrid_get_info_natveg(gi, npatches, ncols, nlunits) end do if (npatches > 0) then - ! Assume that the vegetated landunit has one column - ncols = 1 nlunits = 1 + if (use_hillslope) then + ! ensure ncols is > 0 + ncols = max(ncolumns_hillslope(gi),1) + else + ncols = 1 + endif + ! Assume that each PFT present in the grid cell is present in every column + npatches = ncols*npatches + else ! As noted in natveg_patch_exists, we expect a naturally vegetated landunit in ! every grid cell. This means that npatches should be at least 1 in every grid @@ -220,7 +234,7 @@ end function natveg_patch_exists ! ----------------------------------------------------------------------------- - subroutine subgrid_get_info_cohort(gi, ncohorts) + subroutine subgrid_get_info_cohort(gi, ncols, ncohorts) ! ! !DESCRIPTION: ! Obtain cohort counts per each gridcell. @@ -230,6 +244,7 @@ subroutine subgrid_get_info_cohort(gi, ncohorts) ! ! !ARGUMENTS: integer, intent(in) :: gi ! grid cell index + integer, intent(in) :: ncols ! number of nat veg columns in this grid cell integer, intent(out) :: ncohorts ! number of cohorts in this grid cell ! ! !LOCAL VARIABLES: @@ -248,11 +263,10 @@ subroutine subgrid_get_info_cohort(gi, ncohorts) ! restart vector will just be a little sparse. ! ------------------------------------------------------------------------- - ncohorts = fates_maxElementsPerSite + ncohorts = ncols*fates_maxElementsPerSite end subroutine subgrid_get_info_cohort - !----------------------------------------------------------------------- subroutine subgrid_get_info_urban_tbd(gi, npatches, ncols, nlunits) ! diff --git a/src/main/surfrdMod.F90 b/src/main/surfrdMod.F90 index 23e96e7c1a..03a0082e97 100644 --- a/src/main/surfrdMod.F90 +++ b/src/main/surfrdMod.F90 @@ -721,7 +721,7 @@ subroutine surfrd_veg_all(begg, endg, ncid, ns, actual_numcft) ! Determine weight arrays for non-dynamic landuse mode ! ! !USES: - use clm_varctl , only : create_crop_landunit, use_fates, n_dom_pfts + use clm_varctl , only : create_crop_landunit, use_fates, n_dom_pfts, use_hillslope use clm_varpar , only : natpft_lb, natpft_ub, natpft_size, cft_size, cft_lb, cft_ub use clm_varpar , only : surfpft_lb, surfpft_ub use clm_instur , only : wt_lunit, wt_nat_patch, wt_cft, fert_cft @@ -815,7 +815,12 @@ subroutine surfrd_veg_all(begg, endg, ncid, ns, actual_numcft) ' must also have a separate crop landunit, and vice versa)'//& errMsg(sourcefile, __LINE__)) end if - + + ! Obtain hillslope hydrology information and modify pft weights + if (use_hillslope) then + call surfrd_hillslope(begg, endg, ncid, ns) + endif + ! Convert from percent to fraction wt_lunit(begg:endg,istsoil) = wt_lunit(begg:endg,istsoil) / 100._r8 wt_lunit(begg:endg,istcrop) = wt_lunit(begg:endg,istcrop) / 100._r8 @@ -883,6 +888,115 @@ subroutine surfrd_veg_dgvm(begg, endg) end subroutine surfrd_veg_dgvm !----------------------------------------------------------------------- + subroutine surfrd_hillslope(begg, endg, ncid, ns) + ! + ! !DESCRIPTION: + ! Determine number of hillslopes and columns for hillslope hydrology mode + ! + ! !USES: + use clm_instur, only : ncolumns_hillslope, wt_nat_patch + use clm_varctl, only : nhillslope,max_columns_hillslope + use clm_varpar, only : natpft_size, natpft_lb, natpft_ub + use ncdio_pio, only : ncd_inqdid, ncd_inqdlen + use pftconMod , only : noveg + use HillslopeHydrologyMod, only : pft_distribution_method, pft_standard, pft_from_file, pft_uniform_dominant_pft, pft_lowland_dominant_pft, pft_lowland_upland + use array_utils, only: find_k_max_indices + use surfrdUtilsMod, only: collapse_to_dominant + + ! + ! !ARGUMENTS: + integer, intent(in) :: begg, endg + type(file_desc_t),intent(inout) :: ncid ! netcdf id + integer ,intent(in) :: ns ! domain size + ! + ! !LOCAL VARIABLES: + integer :: g, nh, m, n ! index + integer :: dimid,varid ! netCDF id's + integer :: ier ! error status + integer, allocatable :: max_indices(:) ! largest weight pft indices + logical :: readvar ! is variable on dataset + integer,pointer :: arrayl(:) ! local array (needed because ncd_io expects a pointer) + character(len=32) :: subname = 'surfrd_hillslope' ! subroutine name + logical, allocatable :: do_not_collapse(:) + integer :: n_dominant + !----------------------------------------------------------------------- + + ! number of hillslopes per landunit + call ncd_inqdid(ncid,'nhillslope',dimid,readvar) + if (.not. readvar) then + call endrun( msg=' ERROR: nhillslope not on surface data file'//errMsg(sourcefile, __LINE__)) + else + call ncd_inqdlen(ncid,dimid,nh) + nhillslope = nh + endif + ! maximum number of columns per landunit + call ncd_inqdid(ncid,'nmaxhillcol',dimid,readvar) + if (.not. readvar) then + call endrun( msg=' ERROR: nmaxhillcol not on surface data file'//errMsg(sourcefile, __LINE__)) + else + call ncd_inqdlen(ncid,dimid,nh) + max_columns_hillslope = nh + endif + ! actual number of columns per landunit + allocate(arrayl(begg:endg)) + call ncd_io(ncid=ncid, varname='nhillcolumns', flag='read', data=arrayl, & + dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call endrun( msg=' ERROR: nhillcolumns not on surface data file'//errMsg(sourcefile, __LINE__)) + else + ncolumns_hillslope(begg:endg) = arrayl(begg:endg) + endif + deallocate(arrayl) + + ! pft_from_file and pft_lowland_upland assume that 1 pft + ! will exist on each hillslope column. In prepration, set one + ! pft weight to 100 and the rest to 0. The vegetation type + ! (patch%itype) will be reassigned when initHillslope is called later. + if(pft_distribution_method == pft_from_file .or. & + pft_distribution_method == pft_lowland_upland) then + do g = begg, endg + ! If hillslopes will be used in a gridcell, modify wt_nat_patch, otherwise use original patch distribution + if(ncolumns_hillslope(g) > 0) then + ! First patch gets 100% weight; all other natural patches are zeroed out + wt_nat_patch(g,:) = 0._r8 + wt_nat_patch(g,natpft_lb) = 100._r8 + endif + enddo + + else if (pft_distribution_method == pft_uniform_dominant_pft & + .or. pft_distribution_method == pft_lowland_dominant_pft) then + + ! If hillslopes will be used in a gridcell, modify wt_nat_patch, + ! otherwise use original patch distribution + allocate(do_not_collapse(begg:endg)) + do_not_collapse(begg:endg) = .false. + do g = begg, endg + if (ncolumns_hillslope(g) == 0) then + do_not_collapse(g) = .true. + end if + end do + + if (pft_distribution_method == pft_uniform_dominant_pft) then + ! pft_uniform_dominant_pft uses the patch with the + ! largest weight for all hillslope columns in the gridcell + n_dominant = 1 + else if (pft_distribution_method == pft_lowland_dominant_pft) then + ! pft_lowland_dominant_pft uses the two patches with the + ! largest weights for the hillslope columns in the gridcell + n_dominant = 2 + else + call endrun( msg=' ERROR: unrecognized hillslope_pft_distribution_method'//errMsg(sourcefile, __LINE__)) + end if + + call collapse_to_dominant(wt_nat_patch(begg:endg,:), natpft_lb, natpft_ub, begg, endg, n_dominant, do_not_collapse) + deallocate(do_not_collapse) + + else if (pft_distribution_method /= pft_standard) then + call endrun( msg=' ERROR: unrecognized hillslope_pft_distribution_method'//errMsg(sourcefile, __LINE__)) + endif + + end subroutine surfrd_hillslope + subroutine surfrd_lakemask(begg, endg) ! ! !DESCRIPTION: diff --git a/src/main/surfrdUtilsMod.F90 b/src/main/surfrdUtilsMod.F90 index 6b581a59c1..97f5b7d80f 100644 --- a/src/main/surfrdUtilsMod.F90 +++ b/src/main/surfrdUtilsMod.F90 @@ -235,7 +235,7 @@ subroutine collapse_individual_lunits(wt_lunit, begg, endg, toosmall_soil, & end subroutine collapse_individual_lunits !----------------------------------------------------------------------- - subroutine collapse_to_dominant(weight, lower_bound, upper_bound, begg, endg, n_dominant) + subroutine collapse_to_dominant(weight, lower_bound, upper_bound, begg, endg, n_dominant, do_not_collapse) ! ! DESCRIPTION ! Collapse to the top N dominant pfts or landunits (n_dominant) @@ -251,6 +251,7 @@ subroutine collapse_to_dominant(weight, lower_bound, upper_bound, begg, endg, n_ integer, intent(in) :: lower_bound ! lower bound of pft or landunit indices integer, intent(in) :: upper_bound ! upper bound of pft or landunit indices integer, intent(in) :: n_dominant ! # dominant pfts or landunits + logical, intent(in), optional :: do_not_collapse(begg:endg) ! This array modified in-place ! Weights of pfts or landunits per grid cell ! Dimensioned [g, lower_bound:upper_bound] @@ -277,6 +278,14 @@ subroutine collapse_to_dominant(weight, lower_bound, upper_bound, begg, endg, n_ if (n_dominant > 0 .and. n_dominant < upper_bound) then allocate(max_indices(n_dominant)) do g = begg, endg + + ! original sum of all the weights + wt_sum(g) = sum(weight(g,:)) + + if (present(do_not_collapse) .and. do_not_collapse(g)) then + cycle + end if + max_indices = 0 ! initialize call find_k_max_indices(weight(g,:), lower_bound, n_dominant, & max_indices) @@ -286,7 +295,6 @@ subroutine collapse_to_dominant(weight, lower_bound, upper_bound, begg, endg, n_ ! Typically the original sum of weights = 1, but if ! collapse_urban = .true., it equals the sum of the urban landunits. ! Also set the remaining weights to 0. - wt_sum(g) = sum(weight(g,:)) ! original sum of all the weights wt_dom_sum = 0._r8 ! initialize the dominant pft or landunit sum do n = 1, n_dominant m = max_indices(n) diff --git a/src/main/test/atm2lnd_test/test_downscale_forcings.pf b/src/main/test/atm2lnd_test/test_downscale_forcings.pf index d688ad809d..ddd097d16c 100644 --- a/src/main/test/atm2lnd_test/test_downscale_forcings.pf +++ b/src/main/test/atm2lnd_test/test_downscale_forcings.pf @@ -9,6 +9,7 @@ module test_downscale_forcings use unittestSimpleSubgridSetupsMod use unittestArrayMod use atm2lndType, only : atm2lnd_type, atm2lnd_params_type + use SurfaceAlbedoType, only : surfalb_type use Wateratm2lndBulkType, only : wateratm2lndbulk_type use WaterInfoBulkType, only : water_info_bulk_type use TopoMod, only : topo_type @@ -25,6 +26,7 @@ module test_downscale_forcings @TestCase type, extends(TestCase) :: TestDownscaleForcings type(atm2lnd_type) :: atm2lnd_inst + type(surfalb_type) :: surfalb_inst type(wateratm2lndbulk_type) :: wateratm2lndbulk_inst type(topo_type_always_downscale) :: topo_inst real(r8), allocatable :: eflx_sh_precip_conversion(:) @@ -204,8 +206,13 @@ contains class(TestDownscaleForcings), intent(inout) :: this this%eflx_sh_precip_conversion = col_array() - call downscale_forcings(bounds, this%topo_inst, & - this%atm2lnd_inst, this%wateratm2lndbulk_inst, & + call downscale_forcings(bounds, & + this%topo_inst, & + this%atm2lnd_inst, & + ! Currently surfalb_inst is only used for hillslope downscaling; we need to pass + ! it to satisfy the interface but we haven't bothered setting it up + this%surfalb_inst, & + this%wateratm2lndbulk_inst, & this%eflx_sh_precip_conversion) end subroutine call_downscale_forcings diff --git a/src/main/test/atm2lnd_test/test_partition_precip.pf b/src/main/test/atm2lnd_test/test_partition_precip.pf index 48c12c3f3c..56febc1b30 100644 --- a/src/main/test/atm2lnd_test/test_partition_precip.pf +++ b/src/main/test/atm2lnd_test/test_partition_precip.pf @@ -5,6 +5,7 @@ module test_partition_precip use funit use atm2lndMod use atm2lndType + use ColumnType, only : col use shr_kind_mod, only : r8 => shr_kind_r8 use unittestSubgridMod use unittestSimpleSubgridSetupsMod @@ -64,6 +65,7 @@ contains logical :: l_repartition_rain_snow type(atm2lnd_params_type) :: atm2lnd_params + integer :: c, g if (present(repartition_rain_snow)) then l_repartition_rain_snow = repartition_rain_snow @@ -89,6 +91,15 @@ contains this%wateratm2lndbulk_inst%forc_rain_not_downscaled_grc(bounds%begg:bounds%endg) = rain(:) this%wateratm2lndbulk_inst%forc_snow_not_downscaled_grc(bounds%begg:bounds%endg) = snow(:) this%atm2lnd_inst%forc_t_downscaled_col(bounds%begc:bounds%endc) = temperature(:) + + ! In the production code, column-level versions of forc_rain and forc_snow are + ! initialized to the gridcell-level versions prior to the call to partition_precip; do + ! that here + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + this%wateratm2lndbulk_inst%forc_rain_downscaled_col(c) = this%wateratm2lndbulk_inst%forc_rain_not_downscaled_grc(g) + this%wateratm2lndbulk_inst%forc_snow_downscaled_col(c) = this%wateratm2lndbulk_inst%forc_snow_not_downscaled_grc(g) + end do end subroutine set_inputs @Test diff --git a/src/main/test/surfrdUtils_test/test_surfrdUtils.pf b/src/main/test/surfrdUtils_test/test_surfrdUtils.pf index 98191fbe99..f2fcae7af9 100644 --- a/src/main/test/surfrdUtils_test/test_surfrdUtils.pf +++ b/src/main/test/surfrdUtils_test/test_surfrdUtils.pf @@ -129,7 +129,7 @@ contains call check_sums_equal_1( wt_in_out, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_in_out(begg:,:), wt_expected(begg:,:), tolerance=tol) + @assertEqual(wt_expected(begg:,:), wt_in_out(begg:,:), tolerance=tol) deallocate( wt_expected ) deallocate( wt_in_out ) @@ -249,7 +249,7 @@ contains call check_sums_equal_1( wt_in_out, begg, "test_check_sums_add_to_1", & "should not trigger an error for wt_in_out") - @assertEqual(wt_in_out(begg:,:), wt_expected(begg:,:), tolerance=tol) + @assertEqual(wt_expected(begg:,:), wt_in_out(begg:,:), tolerance=tol) end do @@ -318,7 +318,7 @@ contains isturb_MIN, isturb_MAX, begg, endg, & n_dom_urban) - @assertEqual(wt_in_out(begg:,:), wt_expected(begg:,:), tolerance=tol) + @assertEqual(wt_expected(begg:,:), wt_in_out(begg:,:), tolerance=tol) deallocate( wt_expected ) deallocate( wt_in_out ) @@ -444,7 +444,7 @@ contains call check_sums_equal_1( wt_in_out, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_in_out(begg:,:), wt_expected(begg:,:), tolerance=tol) + @assertEqual(wt_expected(begg:,:), wt_in_out(begg:,:), tolerance=tol) end do ! loop of tests @@ -558,7 +558,7 @@ contains call check_sums_equal_1( wt_nat_patch_in_out, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_nat_patch_in_out(begg:,:), wt_nat_patch_expected(begg:,:), tolerance=tol) + @assertEqual(wt_nat_patch_expected(begg:,:), wt_nat_patch_in_out(begg:,:), tolerance=tol) end do ! loop of tests @@ -570,6 +570,143 @@ contains end subroutine test_collapse_to_dom_pfts + + @Test + subroutine test_collapse_to_dom_do_not_collapse() + ! Tests subroutine collapse_to_dominant when used with an optional logical array indicating which gridcells should actually be collapsed + ! + use pftconMod, only: pftcon + use clm_instur, only: wt_nat_patch + use clm_varpar, only: natpft_lb, natpft_ub + + implicit none + integer, parameter :: begg = 2, endg = 4, natpft_size = 15 + real(r8), allocatable :: wt_nat_patch_expected(:,:) + real(r8), allocatable :: wt_nat_patch_in_out(:,:) ! used in subr. call + real(r8) :: expctd(9) + logical, allocatable :: do_not_collapse(:) + + ! Set relevant pftcon values to defaults; override where necessary + call pftcon%InitForTesting() + natpft_ub = natpft_size - 1 + allocate( wt_nat_patch(begg:endg,natpft_lb:natpft_ub) ) + allocate( wt_nat_patch_expected(begg:endg,natpft_lb:natpft_ub) ) + allocate( wt_nat_patch_in_out(begg:endg,natpft_lb:natpft_ub) ) + allocate( do_not_collapse(begg:endg) ) + + ! INPUT VALUES + wt_nat_patch(begg:,:) = 0._r8 ! initialize + wt_nat_patch(begg:,0) = (/ 30._r8, 40._r8, 0._r8/) ! pft0 + wt_nat_patch(begg:,1) = (/ 15._r8, 11._r8, 15._r8/) ! pft1 + wt_nat_patch(begg:,2) = (/ 5._r8, 5._r8, 5._r8/) ! pft2 + wt_nat_patch(begg:,3) = (/ 0._r8, 4._r8, 35._r8/) ! pft3 + wt_nat_patch(begg:,4) = (/ 10._r8, 10._r8, 35._r8/) ! pft4 + wt_nat_patch(begg:,5) = (/ 40._r8, 30._r8, 10._r8/) ! pft5 + wt_nat_patch(:,:) = wt_nat_patch(:,:) / 100._r8 + call check_sums_equal_1( wt_nat_patch, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + do_not_collapse(begg:) = .true. + + ! OUTPUT VALUES EXPECTED + wt_nat_patch_expected = wt_nat_patch + + call check_sums_equal_1( wt_nat_patch_expected, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + + ! Collapse pfts + wt_nat_patch_in_out = wt_nat_patch ! reset argument for next call + call collapse_to_dominant(wt_nat_patch_in_out(begg:endg,:), & + natpft_lb, natpft_ub, begg, endg, & + 1, & + do_not_collapse(begg:endg)) + + ! Now check that are correct + call check_sums_equal_1( wt_nat_patch_in_out, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + + @assertEqual(wt_nat_patch_expected(begg:,:), wt_nat_patch_in_out(begg:,:), tolerance=0._r8) + + deallocate( wt_nat_patch_expected ) + deallocate( wt_nat_patch_in_out ) + deallocate( wt_nat_patch ) + deallocate( do_not_collapse ) + + call pftcon%clean() + + end subroutine test_collapse_to_dom_do_not_collapse + + + @Test + subroutine test_collapse_to_dom_do_not_collapse_present_false() + ! Tests subroutine collapse_to_dominant when used with an optional logical array indicating which gridcells should actually be collapsed + ! + use pftconMod, only: pftcon + use clm_instur, only: wt_nat_patch + use clm_varpar, only: natpft_lb, natpft_ub + + implicit none + integer, parameter :: begg = 2, endg = 4, natpft_size = 15 + real(r8), allocatable :: wt_nat_patch_expected(:,:) + real(r8), allocatable :: wt_nat_patch_in_out(:,:) ! used in subr. call + real(r8) :: expctd(9) + logical, allocatable :: do_not_collapse(:) + + ! Set relevant pftcon values to defaults; override where necessary + call pftcon%InitForTesting() + natpft_ub = natpft_size - 1 + allocate( wt_nat_patch(begg:endg,natpft_lb:natpft_ub) ) + allocate( wt_nat_patch_expected(begg:endg,natpft_lb:natpft_ub) ) + allocate( wt_nat_patch_in_out(begg:endg,natpft_lb:natpft_ub) ) + allocate( do_not_collapse(begg:endg) ) + + ! INPUT VALUES + wt_nat_patch(begg:,:) = 0._r8 ! initialize + wt_nat_patch(begg:,0) = (/ 30._r8, 40._r8, 0._r8/) ! pft0 + wt_nat_patch(begg:,1) = (/ 15._r8, 11._r8, 15._r8/) ! pft1 + wt_nat_patch(begg:,2) = (/ 5._r8, 5._r8, 5._r8/) ! pft2 + wt_nat_patch(begg:,3) = (/ 0._r8, 4._r8, 35._r8/) ! pft3 + wt_nat_patch(begg:,4) = (/ 10._r8, 10._r8, 35._r8/) ! pft4 + wt_nat_patch(begg:,5) = (/ 40._r8, 30._r8, 10._r8/) ! pft5 + wt_nat_patch(:,:) = wt_nat_patch(:,:) / 100._r8 + call check_sums_equal_1( wt_nat_patch, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + do_not_collapse(begg:) = .false. + + ! OUTPUT VALUES EXPECTED + expctd(1) = 40._r8 / 40._r8 + expctd(2) = 35._r8 / 35._r8 + wt_nat_patch_expected(begg:,:) = 0._r8 ! initialize + wt_nat_patch_expected(begg:,0) = (/ 0._r8, expctd(1), 0._r8 /) ! pft 0 + wt_nat_patch_expected(begg:,3) = (/ 0._r8, 0._r8, expctd(2) /) ! pft 3 + wt_nat_patch_expected(begg:,5) = (/ expctd(1), 0._r8, 0._r8 /) ! pft 5 + + + call check_sums_equal_1( wt_nat_patch_expected, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + + ! Collapse pfts + wt_nat_patch_in_out = wt_nat_patch ! reset argument for next call + call collapse_to_dominant(wt_nat_patch_in_out(begg:endg,:), & + natpft_lb, natpft_ub, begg, endg, & + 1, & + do_not_collapse(begg:endg)) + + ! Now check that are correct + call check_sums_equal_1( wt_nat_patch_in_out, begg, "test_check_sums_add_to_1", & + "should not trigger an error") + + @assertEqual(wt_nat_patch_expected(begg:,:), wt_nat_patch_in_out(begg:,:), tolerance=0._r8) + + deallocate( wt_nat_patch_expected ) + deallocate( wt_nat_patch_in_out ) + deallocate( wt_nat_patch ) + deallocate( do_not_collapse ) + + call pftcon%clean() + + end subroutine test_collapse_to_dom_do_not_collapse_present_false + + @Test subroutine test_collapse_crop_types_none() ! This test sets cftsize = 0, ie crops are lumped together with unmanaged @@ -598,8 +735,8 @@ contains call collapse_crop_types( wt_cft, fert_cft, cftsize, begg, endg, verbose = .true.) ! Now check that are correct - @assertEqual(wt_cft(begg:,:), wt_cft_expected(begg:,:)) - @assertEqual(fert_cft(begg:,:), fert_cft_expected(begg:,:)) + @assertEqual(wt_cft_expected(begg:,:), wt_cft(begg:,:)) + @assertEqual(fert_cft_expected(begg:,:), fert_cft(begg:,:)) call pftcon%clean() end subroutine test_collapse_crop_types_none @@ -645,11 +782,11 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:), wt_cft_expected(begg:,:)) + @assertEqual(wt_cft_expected(begg:,:), wt_cft(begg:,:)) ! INTENTIONAL? As written, subr. collapse_crop_types does NOT take ! ----------- the avg fert_cft of the irrigated and unirrigated when ! irrigate = .false.. Assuming intentional for now. - @assertEqual(fert_cft(begg:,:), fert_cft_expected(begg:,:)) + @assertEqual(fert_cft_expected(begg:,:), fert_cft(begg:,:)) call pftcon%clean() end subroutine test_collapse_crop_types_16_to_15 @@ -694,8 +831,8 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:), wt_cft_expected(begg:,:)) - @assertEqual(fert_cft(begg:,:), fert_cft_expected(begg:,:)) + @assertEqual(wt_cft_expected(begg:,:), wt_cft(begg:,:)) + @assertEqual(fert_cft_expected(begg:,:), fert_cft(begg:,:)) call pftcon%clean() end subroutine test_collapse_crop_types_16_to_16 @@ -750,8 +887,8 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:2), wt_cft_expected(begg:,:2)) - @assertEqual(fert_cft(begg:,:2), fert_cft_expected(begg:,:2)) + @assertEqual(wt_cft_expected(begg:,:2), wt_cft(begg:,:2)) + @assertEqual(fert_cft_expected(begg:,:2), fert_cft(begg:,:2)) call pftcon%clean() end subroutine test_collapse_crop_types_18_to_16 @@ -806,8 +943,8 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:2), wt_cft_expected(begg:,:2)) - @assertEqual(fert_cft(begg:,1), fert_cft_expected(begg:,1)) + @assertEqual(wt_cft_expected(begg:,:2), wt_cft(begg:,:2)) + @assertEqual(fert_cft_expected(begg:,1), fert_cft(begg:,1)) call pftcon%clean() end subroutine test_collapse_crop_types_18_to_15 @@ -855,8 +992,8 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:), wt_cft_expected(begg:,:)) - @assertEqual(fert_cft(begg:,:), fert_cft_expected(begg:,:)) + @assertEqual(wt_cft_expected(begg:,:), wt_cft(begg:,:)) + @assertEqual(fert_cft_expected(begg:,:), fert_cft(begg:,:)) call pftcon%clean() end subroutine test_collapse_crop_types_18_to_18 @@ -914,8 +1051,8 @@ contains ! Now check that are correct call check_sums_equal_1( wt_cft/100.0_r8, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_cft(begg:,:), wt_cft_expected(begg:,:)) - @assertEqual(fert_cft(begg:,:), fert_cft_expected(begg:,:)) + @assertEqual(wt_cft_expected(begg:,:), wt_cft(begg:,:)) + @assertEqual(fert_cft_expected(begg:,:), fert_cft(begg:,:)) call pftcon%clean() end subroutine test_collapse_crop_types_20_to_18 @@ -972,7 +1109,7 @@ contains call check_sums_equal_1( wt_nat_patch, begg, "test_check_sums_add_to_1", & "should not trigger an error") @assertEqual(wtpft,wt_nat_patch) - @assertEqual(wt_lunit(begg:,istsoil),(/1.00_r8,1.00_r8/)) + @assertEqual((/1.00_r8,1.00_r8/), wt_lunit(begg:,istsoil)) deallocate( wt_nat_patch ) deallocate( wtpft ) @@ -1023,10 +1160,10 @@ contains "should not trigger an error") call check_sums_equal_1( wt_nat_patch, begg, "test_check_sums_add_to_1", & "should not trigger an error") - @assertEqual(wt_lunit(begg:,istsoil), (/1.00_r8,1.00_r8/)) - @assertEqual(wt_nat_patch(begg:,ndllf_evr_tmp_tree),(/0.25_r8,0.25_r8/)) - @assertEqual(wt_nat_patch(begg:,nc3crop), (/0.1875_r8,0.1875_r8/)) - @assertEqual(wt_nat_patch(begg:,nc3irrig), (/0.5625_r8,0.5625_r8/)) + @assertEqual((/1.00_r8,1.00_r8/), wt_lunit(begg:,istsoil)) + @assertEqual((/0.25_r8,0.25_r8/), wt_nat_patch(begg:,ndllf_evr_tmp_tree)) + @assertEqual((/0.1875_r8,0.1875_r8/), wt_nat_patch(begg:,nc3crop)) + @assertEqual((/0.5625_r8,0.5625_r8/), wt_nat_patch(begg:,nc3irrig)) call pftcon%clean() end subroutine test_convert_cft_to_pft @@ -1071,7 +1208,7 @@ contains array(lb+1,lb2+2) = array(lb+1,lb2+2) + eps call check_sums_equal_1( array, lb, "test_check_sums_add_to_1_fail", & "should trigger an error", ier) - @assertEqual(ier,-10) + @assertEqual(-10, ier) end subroutine test_check_sums_add_to_1_fail @Test subroutine test_renormalize @@ -1096,7 +1233,7 @@ contains ! Make the normalized result 100, so multiply the expected result by 100 expected(:,:) = expected(:,:)*100.0d00 call renormalize(array, lb, 100.0d00) - @assertEqual(array, expected, tolerance=tol) + @assertEqual(expected, array, tolerance=tol) ! divide by 100 and should add to one array = array / 100.0d00 call check_sums_equal_1( array, lb, "test_check_sums_add_to_1", & @@ -1104,7 +1241,7 @@ contains ! Call again returning error code, make sure error code is zero call check_sums_equal_1( array, lb, "test_check_sums_add_to_1", & "should not trigger an error", ier) - @assertEqual(ier,0) + @assertEqual(0, ier) end subroutine test_renormalize @Test @@ -1118,7 +1255,7 @@ contains array(:,:) = 0.0d00 expected(:,:) = array call renormalize(array, lb, 100.0d00) - @assertEqual(array, expected, tolerance=tol) + @assertEqual(expected, array, tolerance=tol) end subroutine test_renormalize_zero end module test_surfrdUtils diff --git a/src/utils/clmfates_interfaceMod.F90 b/src/utils/clmfates_interfaceMod.F90 index 7039884847..da167d9266 100644 --- a/src/utils/clmfates_interfaceMod.F90 +++ b/src/utils/clmfates_interfaceMod.F90 @@ -2123,7 +2123,7 @@ subroutine wrap_sunfrac(this,nc,atm2lnd_inst,canopystate_inst) call t_startf('fates_wrapsunfrac') - associate( forc_solad => atm2lnd_inst%forc_solad_grc, & + associate( forc_solad => atm2lnd_inst%forc_solad_not_downscaled_grc, & forc_solai => atm2lnd_inst%forc_solai_grc, & fsun => canopystate_inst%fsun_patch, & laisun => canopystate_inst%laisun_patch, &